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

New Member
Joined
Aug 1, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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!!!
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
2,198
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.

Code:
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

New Member
Joined
Aug 1, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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.

Code:
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?

1659424911574.png
 

alxfrh

New Member
Joined
Aug 1, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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 ...
 

Attachments

  • error.jpg
    error.jpg
    18.6 KB · Views: 3
  • error 2.jpg
    error 2.jpg
    18.5 KB · Views: 3

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
2,198
force the name to be legitimate. you cant have gigantic long sheet names.
 

Forum statistics

Threads
1,175,833
Messages
5,899,728
Members
434,797
Latest member
natejxoticpc

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
Top