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]

Are this question same as this post:
How to append data of particular sheet from multiple excel files into one excel file?

 

[swarupa]

No

 

[swarupa]

Dear,
You are providing code at Monday 2.32 pm. This code is exactly i want but i think it is need to change.
I want to extracting only sheet1 of excel files present in Folder "A" and rename all sheet on the base of cell value F6.
Following code is a part of your code which gives a error for this line ? "ActiveSheet.Name = ActiveSheet.Range("F6")"

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()


Please see my first code :

following lines are a part of my first code

With wbOpen
.Sheets("Sheet1").Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
ActiveSheet.Name = ActiveSheet.Range("F6")

with above part of my first code i am extracting only sheet1 of excel files present in Folder "A" and rename all sheet on the base of cell value F6.
So how to insert these code lines in your code.

 

[maabadi]

But the solution is same only Chane sheet name from Summery to Sheet1 at Code Come at Post #11 that Thread.
Are you see that post. Don't see action or reply on it.
I change that code to work for your condition.
if you want file open dialog box for select folder, I think you can combine this code with previous code, if Not tell me to do it.

Sub MergeSheets2()

Dim xStrPath As String, xStrName As String
Dim xStrFName As String, xArr As Variant
Dim xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String,  xI As Integer, Sh1 as Worksheet

On Error Resume Next

xStrPath = "C:\Users\swaroopa.bp\Desktop\A\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xTWB = ThisWorkbook
xStrFName = Dir(xStrPath & "*.xlsx")
Do While Len(xStrFName) > 0
Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
Set Sh1 = Sheets("Sheet1")
xStrName = Sh1.Name
xArr = Split(xStrName, ",")
For Each xWS In ActiveWorkbook.Sheets
For xI = 0 To UBound(xArr)
If xWS.Name = xArr(xI) Then
xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
xMWS.Name = xStrAWBName & "(" & ActiveSheet.Range("F6") & ")"
Exit For
End If
Next xI
Next xWS
Workbooks(xStrAWBName).Close
xStrFName = Dir()
Loop
xTWB.SaveAs Filename:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[swarupa]

Dear maabadi,
I am really sorry. I very new in VBA. But I will try to combine both the code. Again sorry for trouble you lots of time.

 

[maabadi]

Try this:

Sub ImportFiles()
Dim wbOpen As Workbook, wbNew As Workbook, fName As String, strPath As String
Dim xStrPath As String, xStrName As String, xStrFName As String, xArr As Variant
Dim xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook, Sheet As Worksheet
Dim xStrAWBName As String,  xI As Integer, Sh1 as Worksheet, FolderName As String
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, CName As String, Cell As Range
On Error Resume Next
  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
Set xTWB = ThisWorkbook
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
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
Set Sh1 = Sheets("Sheet1")
xStrName = Sh1.Name
xArr = Split(xStrName, ",")
For Each xWS In ActiveWorkbook.Sheets
For xI = 0 To UBound(xArr)
If xWS.Name = xArr(xI) Then
xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count)
Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
xMWS.Name = xStrAWBName & "(" & ActiveSheet.Range("F6") & ")"
Exit For
End If
Next xI
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs Filename:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation=xlCalculationAutomatic
End Sub

 

[swarupa]

Thanks
I will try this. But dear maadabi i also want to combine following line of code. I really sorry to trouble you many times.

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

 

[maabadi]

Then Replace This:

Loop
xTWB.SaveAs Filename:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal

With

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:
xTWB.SaveAs FileName:="C:\Users\swaroopa.bp\Desktop\C\Consolidation_" & CName, FileFormat:=xlWorkbookNormal

At Above code.

 

[swarupa]

Thanks a lot

 

[maabadi]

You're Welcome.