excel - VBA append many workbooks to correct tabs

Question

I have around 500 workbooks that I have managed to import into a master workbook into separate tabs. I want to be able to append data from each of the separate workbooks into the correct tab of the master workbook on a weekly basis.

Below is the code I have so far:

Sub ImportData()

Dim Path As String, Filename As String
Dim wb As Workbook
Dim Sht As Worksheet, ShtDest As Worksheet

Path = "C:\Users\J\Currencies\"
Filename = Dir(Path & "*.xlsx*")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Do While Filename <> ""
    Set wb = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
    For Each Sht In wb.Sheets
        Set ShtDest = ThisWorkbook.Sheets.Add(After:=Sheets(1))
        Sht.Cells.Copy
        ShtDest.Name = Left(wb.Name, 6) 
        ShtDest.Cells.PasteSpecial xlValues
    Next Sht
    wb.Close
    Filename = Dir()
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

I think I need to add some sort of if statement to check if the name of the workbook that is being opened is the same as each of the individual worksheet names in the master workbook. Perhaps I need a second for each loop to check each of the worksheets in the master workbook? Then for each of the worksheets in the master workbook, find the last populated row and append the data, one row below that.

标签： excelvba

Answer 1

You can check the name of the workbook worksheets, and paste your values in there. Find below some unchecked and undebugged sample code:

    Dim ShtDest As Worksheet
    Dim wsName As String
    wsName = 'yourWorkSheetNameToFind'
    Set ShtDest = wb.Sheets(wsName)
    ShtDest.Cells.PasteSpecial xlValues

Even add an ifExists checker:

Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

So, with the checker:

Dim ShtDest As Worksheet
Dim wsName As String
wsName = 'yourWorkSheetNameToFind'
Set ShtDest = wb.Sheets(wsName)
if WorksheetExists(wsName, wb)
    ShtDest.Cells.PasteSpecial xlValues