VBA to match the workbook name with worksheet name

[goody2006]

Hello,

I did some research on the macro I need but I guess this one was not asked before. I have a challenge in front of me which will save tons of time to me. Here is what I need:

I have 30+ workbooks in a directory, each has only one sheet. I have another main spreadsheet where I am doing all the calculations. This main spreadsheet has sheets with the same names with only an extension added at the beginning. To be more specific, let's say the workbooks in the directory are named: ABC.xlsx, DEF.xlsx, GHI.xlsx and the main spreadsheet has sheets named X_ABC, X_DEF, X_GHI. The reason for that I have other sheets in that main workbook. I have some other macros that are calling based on the extension at the beginning.

I need to copy the information in sheet1 of ABC.xlsx into the sheet named X_ABC , DEF.xlsx into the sheet named X_DEF, ... of the main spreadsheet if that sheet exists in the main workbook.

Is this even possible?
I appreciate any help.

Thanks for looking my message.

 

[netuser]

Here you go, change the name of your main sheet and path of your workbooks. I have put fix name of sheet1 to copy but see my comment where you can change to 1st sheet if this is what you want.

Sub CopytoSheet()
'
' Copy same name workbook in worksheet
'

    Dim PathOfWorkbboks
    Dim objFolder As Object
    Dim objFile As Object
    Dim Main
    Dim ShtName, objName
    
Main = "Classeur1.xlsx" 'Change name of your main workbook here
         
Windows(Main).Activate
PathOfWorkbboks = "C:\Temp\"  ' Change to the path where all workbooks are
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(PathOfWorkbboks)
 
    For x = 1 To Sheets.Count
        With Sheets(x)
        Sheets(x).Activate
        ShtName = Mid(Sheets(x).Name, 3, Len(Sheets(x).Name) - 2) & ".xlsx"
            For Each objFile In objFolder.Files
            objName = objFSO.Getfilename(objFile.path)
            If objName = ShtName Then
               Workbooks.Open objFile
               Sheets("sheet1").Select ' Change this to Sheets(1).Select  if it was not your sheet name but 1st sheet you want to copy
               Cells.Select
               Selection.Copy
               Windows(Main).Activate
               Range("A1").Select
               ActiveSheet.Paste
               Application.CutCopyMode = False
               Workbooks(objName).Close savechanges:=False
            End If
            Next
        End With
    Next x

End Sub

 

[goody2006]

OMG! netuser, You are awesome! It works like a charm. I was expecting a response like it was impossible. You saved me a great amount of time.

 

[netuser]

You are welcome, I am happy it helped