How to save filename based on cell range?

S

swarupa

New Member
Joined
Jan 2, 2021
Messages
32
Office Version
  1. 2010
Platform
  1. Windows
Hello,
I extracting 12 excel files in to one workbook with the help of following code.

Sub ImportFiles()
Dim wbOpen As Workbook
Dim wbNew As Workbook
Dim fName As String
'Change Path
Const strPath As String = "C:\Users\s\Desktop\A\"
Dim strExtension As String
MsgBox ("Do you Want to Extract Files?")
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
'Change extension
strExtension = Dir("*.xls")
Set wbNew = Workbooks.Add
'Change Path, Name and File Format
wbNew.SaveAs Filename:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen
.Sheets("Sheet1").Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
ActiveSheet.Name = ActiveSheet.Range("F6")
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
MsgBox ("Files Extracted Succussfully")
fName = Dir("C:\Users\s\Desktop\A\*.*")
Do While fName <> ""
If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill "C:\Users\s\Desktop\A\" & fName
End If
fName = Dir
Loop
End Sub
1. I want select path when VBA Code is run. So I want to change the following line
Const strPath As String = "C:\Users\s\Desktop\A\"
1. I also want to change the following line of above code
wbNew.SaveAs Filename:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
I want to filename should be based on cell range(C9:F9) like
Consolidation_XYZ (XYZ is vendor name which is in C9:F9)
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Sort by date Sort by votes
I don't Know what to do this at code:
VBA Code: 
If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill StrPath & fName
End If
Test this:
VBA Code: 
Option Explicit

Sub ImportFiles()
Dim wbOpen As Workbook, wbNew As Workbook, fName As String, j As Long, P As String
Dim StrPath As String, fldr As FileDialog, strExtension As String
'Change Path
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
StrPath = sItem & "\"
MsgBox ("Do you Want to Extract Files?")
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir StrPath
'Change extension
strExtension = Dir("*.xls")
For j = 3 To 6
P = Cells(9, j).Value
If P = "" Then GoTo Resum
Set wbNew = Workbooks.Add
'Change Path, Name and File Format
wbNew.SaveAs Filename:="C:\Users\swaroopa.bp\Desktop\C\Consolidation_" & P, FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(StrPath & strExtension)
With wbOpen
.Sheets("Sheet1").Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
ActiveSheet.Name = ActiveSheet.Range("F6")
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
MsgBox ("Files Extracted Succussfully")
fName = Dir(StrPath & "*.*")
Do While fName <> ""
If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill StrPath & fName
End If
fName = Dir
Loop
Resum:
Next j
End Sub
 
Upvote 0
No, its not work.

I am extracting 12 excel files for one vendor. I have many vendors with 10 or 12 excel files. Every excel file is a vendor form. Each excel file have only one sheet namely “sheet1”. The vendor name is in Cell range (C9:F9) of every excel file. I want to extracting all these 12 excel files “Sheet1” in to one workbook. So what I want when I am extracting these files in one workbook I want to save this excel file name base on cell range (C9:F9) i.e. vendor name.
 
Upvote 0
No answer. :(
? if it is possible then also ok for me.

I have folder “A”. In this folder I have 12 excel file with only one sheet i.e. “Sheet1”.
Excel file name is like 01_ABCD_C01 April, 01_ABCD_C01 May ………01_ABCD_C01 December etc.
Here C01 is vendor ID
I am extracting “Sheet1” of every excel file in one WorkBook and change sheet1 name base on cell value F6 and save file in C folder. I am doing this task for every vendor. I am using following code for this. Now my question is : when I save excel file in C folder then the name of extracted file is base (01_ABCD_C01 April) on client id. The every excel file name contains C01 is a client ID.
 
Upvote 0
swarupa said:
1. I also want to change the following line of above code
wbNew.SaveAs Filename:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
I want to filename should be based on cell range(C9:F9) like
Consolidation_XYZ (XYZ is vendor name which is in C9:F9)
Click to expand...
You have one Combined file then you want save as multiple name for each sheet? It isn't Possible?
What you exact want.
For first:

Try this:
VBA Code: 
Option Explicit

Sub ImportFiles()
Dim wbOpen As Workbook, wbNew As Workbook, fName As String, strPath As String
Dim FolderPath As String, fldr As FileDialog, sItem As String, FolderName As String
Dim FileName As String, Sheet As Worksheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
    
Set wbNew = Workbooks.Add
wbNew.SaveAs FileName:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
FileName = Dir(FolderPath & "*.xls*")
MsgBox ("Do you Want to Extract Files?")
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While FileName <> ""
 Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
 For Each Sheet In ActiveWorkbook.Sheets
 Sheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
 ActiveSheet.Name = ActiveSheet.Range("F6")
'wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
 Next Sheet
 Workbooks(FileName).Close
 FileName = Dir()
Loop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
MsgBox ("Files Extracted Succussfully")
fName = Dir(FolderPath & "*.*")
Do While fName <> ""
If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill FolderPath & fName
End If
fName = Dir
Loop
End Sub
 
Upvote 0
The above code is works. It create excel file with 12 sheet having name consolidation. But I have many vendors. every vendors combined file name is consolidation. so it is very difficult to search consolidation file of particular no. so i want when vba create consolidation file at the same time file name should be with vendor name or vendor id. Vendor name keep in every excel file which i pull. Vendor name in cell range (C9:f9). OR on base on Vendor ID. My every excel file name contains vendor id. For example MATRQ_CB0000000000001_2018 April, MATRQ_CB0000000000001_2018 May......so on upto 2019 March total 12 files. another vendor having MATRQ_CB0000000000002_2018 April, MATRQ_CB0000000000002_2018 May.....so on upto 2019 March total 12 files. These excel file fill by vendor in every month.
wbNew.SaveAs FileName:="C:\Users\swaroopa.bp\Desktop\C\Consolidation"
☝️above line combine 12 excel files of vendor ID CB0000000000001 with file name Consolidation. but i want to file name should be Consolidation_CB0000000000001.
 
Upvote 0
OK. Then I think we can Use only one of this Vendor at all file to Extract from them then, I use the Last file that copied to Last sheet Cell C9:F9
VBA Code: 
Sub ImportFiles()
Dim wbOpen As Workbook, wbNew As Workbook, fName As String, strPath As String
Dim FolderPath As String, fldr As FileDialog, sItem As String, FolderName As String
Dim FileName As String, Sheet As Worksheet, CName As String, Cell As Range
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
   
Set wbNew = Workbooks.Add
FileName = Dir(FolderPath & "*.xls*")
MsgBox ("Do you Want to Extract Files?")
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
ActiveSheet.Name = ActiveSheet.Range("F6")
'wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
Next Sheet
Workbooks(FileName).Close
FileName = Dir()
Loop
For Each Cell In Range("C9:F9")
If Cell.Value = "" Then
Else
CName = Mid(Cell, 7, Len(Cell) - 11)
Debug.Print CName
GoTo Resum
End If

Next Cell
Resum:
wbNew.SaveAs FileName:="C:\Users\swaroopa.bp\Desktop\C\Consolidation_" & CName, FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
MsgBox ("Files Extracted Succussfully")
fName = Dir(FolderPath & "*.*")
Do While fName <> ""
If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill FolderPath & fName
End If
fName = Dir
Loop
End Sub
 
Upvote 0
Thanks it works:):):).
It is very helpful for me to do my work efficiently. You are sooo nice.
 
Upvote 0
You're Welcome & Glad we can Help.
Don't forgot to tick solved post at right side of Answer.
 
Upvote 0
Solution
In above code i want little bit change.
I want to extract only "Sheet1".
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA - link to [any] the current user's desktop
Replies
4
Views
990
AV_Geek
A
Guna13
  • Question Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
391
Guna13
Guna13
L
  • Solved
Fixing VBA code
Replies
3
Views
684
Joe4
Joe4
C
  • Question Question
Need to add to my search worksheet
Replies
1
Views
104
craigwojo
C
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
939
GarnesGambit
G

Forum statistics

Threads
1,223,909
Messages
6,175,310
Members
452,634
Latest member
cpostell

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top