how to copy 1 sheet from several workbooks in 1 folder to a new workbook and rename the sheets according to an excel list

[alxfrh]

Hi,

I have several workbooks that sit in one folder (folder name "test 1")
I want to copy 1 sheet (sheet name "6_1") from each of those workbooks and combine them into 1 new workbook (new workbook name "Copiedsheets")
I would also like to rename those new copied sheets by combining a list of names in excel (file name "list of names" and the list starts from A2 onward) with their original sheet name (sheet name "6_1")

Could you please help me do that using VBA? I could find approximate answers but not the ones I was looking for

Thank you!!!

 

[ranman256]

wbMain uses this code to assemble the sheets.
paste the code into module.

B1: put the folder name: like: c:\temp\
B2: put the sheet name: '6_1

then run : GetAllFileSheets
(put a button on the sheet next to B1 & B2 area to run this macro)

the code will then scan the folder, open the wb, grab the sheet (mentioned in B2)
then create a RESULTS.xls sheet when done.

modify as needed on naming conventions.

Option Explicit
Public gvTypCode, gvShtBase

Public Sub GetAllFileSheets()
Dim vStartDir

vStartDir = FixDir(Range("B1").Value)
gvShtBase = Range("B2").Value

  'set vals
ScanFilesIn1Folder vStartDir

Range("A1").Select
MsgBox "Done"
End Sub

private  Sub ScanFilesIn1Folder(ByVal pvStartDir)
Dim FileSystem As Object
Dim Folder As Object
Dim oFile As Object
Dim vName
Dim wbSrc As Workbook, wbTarg As Workbook
Dim wsSrc
Dim vShtBase

    Workbooks.Add
    ActiveWorkbook.SaveAs "c:\temp\results.xlsx"
  

Set wbTarg = ActiveWorkbook

Set FileSystem = CreateObject("Scripting.FileSystemObject")
Set Folder = FileSystem.GetFolder(pvStartDir)

For Each oFile In Folder.Files
  
    If InStr(oFile.Name, ".xls") > 0 Then       'If InStr(oFile.Name, ".accdb") > 0 Or InStr(oFile.Name, ".mdb") > 0 Then
       vName = oFile.Name
       Workbooks.Open oFile
       Set wbSrc = ActiveWorkbook
       Set wsSrc = wbSrc.Sheets(gvShtBase)
       wsSrc.Activate
     
         'copy sheet
    Sheets(gvShtBase).Select
    Sheets(gvShtBase).Copy Before:=wbTarg.Sheets(1)
    Sheets(gvShtBase).Select
    Sheets(gvShtBase).Name = vName & "_" & gvShtBase

    wbSrc.Close False

    End If
  
skip1:
Next

Set oFile = Nothing
Set Folder = Nothing
Set FileSystem = Nothing
End Sub


'check dir path has a backslash at the end for attaching more files or dirs to it
private  Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

 

[alxfrh]

wbMain uses this code to assemble the sheets.
paste the code into module.

B1: put the folder name: like: c:\temp\
B2: put the sheet name: '6_1

then run : GetAllFileSheets
(put a button on the sheet next to B1 & B2 area to run this macro)

the code will then scan the folder, open the wb, grab the sheet (mentioned in B2)
then create a RESULTS.xls sheet when done.

modify as needed on naming conventions.

Option Explicit
Public gvTypCode, gvShtBase

Public Sub GetAllFileSheets()
Dim vStartDir

vStartDir = FixDir(Range("B1").Value)
gvShtBase = Range("B2").Value

  'set vals
ScanFilesIn1Folder vStartDir

Range("A1").Select
MsgBox "Done"
End Sub

private  Sub ScanFilesIn1Folder(ByVal pvStartDir)
Dim FileSystem As Object
Dim Folder As Object
Dim oFile As Object
Dim vName
Dim wbSrc As Workbook, wbTarg As Workbook
Dim wsSrc
Dim vShtBase

    Workbooks.Add
    ActiveWorkbook.SaveAs "c:\temp\results.xlsx"
 

Set wbTarg = ActiveWorkbook

Set FileSystem = CreateObject("Scripting.FileSystemObject")
Set Folder = FileSystem.GetFolder(pvStartDir)

For Each oFile In Folder.Files
 
    If InStr(oFile.Name, ".xls") > 0 Then       'If InStr(oFile.Name, ".accdb") > 0 Or InStr(oFile.Name, ".mdb") > 0 Then
       vName = oFile.Name
       Workbooks.Open oFile
       Set wbSrc = ActiveWorkbook
       Set wsSrc = wbSrc.Sheets(gvShtBase)
       wsSrc.Activate
    
         'copy sheet
    Sheets(gvShtBase).Select
    Sheets(gvShtBase).Copy Before:=wbTarg.Sheets(1)
    Sheets(gvShtBase).Select
    Sheets(gvShtBase).Name = vName & "_" & gvShtBase

    wbSrc.Close False

    End If
 
skip1:
Next

Set oFile = Nothing
Set Folder = Nothing
Set FileSystem = Nothing
End Sub


'check dir path has a backslash at the end for attaching more files or dirs to it
private  Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

I am getting this debug error
how should i correct it?

 

[alxfrh]

i run the code
it shows me the errors attached in the picture

a new WB called 'results' is created but only with 1 sheet from the 1st workbook
the rest don't follow.

I tried looking into the sheets to see if there are any special characters, blank space or exceeded 31 characters, but that wasn't the case

I don't know where to go from here ...

 

[ranman256]

force the name to be legitimate. you cant have gigantic long sheet names.

 

[alxfrh]

force the name to be legitimate. you cant have gigantic long sheet names.

it worked like magic, thanks a lot for your help