Vba to open all workbooks and copy a specif sheet to master workbook

[Diras]

Hello,

I have about 100 files and i need to extract one specific sheet name "ADDBC" to a Master Workbook.
The ideia is to have the master workbook with the the sheetname+fileorigin.
So on master workbook i would have sheets:

ADDBC File 1 / ADDBC Files 2 / ADDBC Files 2.

I have tried several macros found but no luck
...
Could anyone help me please .
Thank you

 

[mumps]

Try this macro. Change the folder path and file extension (in red) to suit your needs. Keep in mind that sheet names can have no more than 31 characters so if you have a file name of more than 25 characters (this takes into account "ADDBC "), an error will be generated. The other alternative would be to modify the macro to truncate the name to 31 characters. Please advise.

Sub CopySheet()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("ADDBC").Copy after:=wkbDest.Sheets(wkbDest.Sheets.Count)
            wkbDest.Sheets(wkbDest.Sheets.Count).Name = "ADDBC" & " " & Left(wkbSource.Name, InStr(wkbSource.Name, ".") - 1)
            .Close savechanges:=True
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Diras]

Try this macro. Change the folder path and file extension (in red) to suit your needs. Keep in mind that sheet names can have no more than 31 characters so if you have a file name of more than 25 characters (this takes into account "ADDBC "), an error will be generated. The other alternative would be to modify the macro to truncate the name to 31 characters. Please advise.

Sub CopySheet()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("ADDBC").Copy after:=wkbDest.Sheets(wkbDest.Sheets.Count)
            wkbDest.Sheets(wkbDest.Sheets.Count).Name = "ADDBC" & " " & Left(wkbSource.Name, InStr(wkbSource.Name, ".") - 1)
            .Close savechanges:=True
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Thank you very much for the code.
I works well for the files which the names is short.
Who i would increde the file name to more caracteres?

Thank you in advance.

 

[mumps]

Excel does not allow any sheet names to be longer than 31 characters. Do you want the macro to shorten all the sheet names to 31 characters?

 

[Diras]

Excel does not allow any sheet names to be longer than 31 characters. Do you want the macro to shorten all the sheet names to 31 characters?

Yes, how to do?

 

[mumps]

Try:

Sub CopySheet()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("ADDBC").Copy after:=wkbDest.Sheets(wkbDest.Sheets.Count)
            wkbDest.Sheets(wkbDest.Sheets.Count).Name = Left("ADDBC" & " " & Left(wkbSource.Name, InStr(wkbSource.Name, ".") - 1), 31)
            .Close savechanges:=True
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Diras]

Thanks a lot for your help budy. Worked well for my needs.

 

[mumps]

You are very welcome.