How to save filename based on cell range?

[swarupa]

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)

 

[maabadi]

I don't Know what to do this at code:

If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill StrPath & fName
End If

Test this:

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

 

[swarupa]

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.

 

[swarupa]

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.

 

[maabadi]

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)

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:

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

 

[swarupa]

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.

 

[maabadi]

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

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

 

[swarupa]

Thanks it works.
It is very helpful for me to do my work efficiently. You are sooo nice.

 

[maabadi]

You're Welcome & Glad we can Help.
Don't forgot to tick solved post at right side of Answer.

 

[swarupa]

In above code i want little bit change.
I want to extract only "Sheet1".