Объединение таблиц в Excel - VBA

Question

My Excel do c извлекает информацию из внешних файлов и сохраняет ее на 5 отдельных листах / в таблицах. Каждая таблица имеет одинаковые столбцы и порядок, но количество строк меняется ежедневно.

То, что я пытался сделать, это объединить все данные в одну таблицу. Есть ли более эффективный способ сделать это, чем мой код копирования / вставки ниже?

Это код только для 2 таблиц. Всего я хочу объединить 5 таблиц.

Sub merge()
Dim wb As Workbook:         Set wb = Workbooks("MASTER.xlsm")
Dim masterWS As Worksheet:  Set masterWS = wb.Worksheets("MASTER")
Dim WS1 As Worksheet:     Set WS1 = wb.Worksheets("1")
Dim WS2 As Worksheet:    Set WS2 = wb.Worksheets("2")
Dim WS3 As Worksheet:    Set WS3 = wb.Worksheets("3")
Dim WS4 As Worksheet:    Set WS4 = wb.Worksheets("4")
Dim WS5 As Worksheet:     Set WS5 = wb.Worksheets("5")

Dim counter1 As Long
Dim counter2 As Long
Dim counter3 As Long
Dim counter4 As Long
Dim counter5 As Long
Dim counter As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

' Count rows for each account
WS1.Activate
counter1 = WS1.Range("A11", Range("A11").End(xlDown)).Rows.Count
WS2.Activate
counter2 = WS2.Range("A11", Range("A11").End(xlDown)).Rows.Count
WS3.Activate
counter3 = WS3.Range("A11", Range("A11").End(xlDown)).Rows.Count
WS4.Activate
counter4 = WS4.Range("A11", Range("A11").End(xlDown)).Rows.Count
WS5.Activate
counter5 = WS5.Range("A11", Range("A11").End(xlDown)).Rows.Count

' Sum of counter
counter = counter1 + counter2 + counter3 + counter4 + counter5

While counter > 0
    If counter1 > 0 Then
        counter = counter - counter1
        WS1.Range("E11:E" & counter1 + 10).Copy 
        masterWS.Range("B:B" & counter).PasteSpecial xlPasteAll

        WS1.Range("I11:I" & counter1 + 10).Copy
        masterWS.Range("C:C" & counter).PasteSpecial xlPasteAll

        WS1.Range("J11:J" & counter1 + 10).Copy
        masterWS.Range("D:D" & counter).PasteSpecial xlPasteAll

        WS1.Range("K11:K" & counter1 + 10).Copy 
        masterWS.Range("E:E" & counter).PasteSpecial xlPasteAll

        WS1.Range("S11:S" & counter1 + 10).Copy 'BROKER
        masterWS.Range("F:F" & counter).PasteSpecial xlPasteAll

        WS1.Range("B11:B" & counter1 + 10).Copy 'TD
        masterWS.Range("G:G" & counter).PasteSpecial xlPasteAll

        WS1.Range("C11:C" & counter1 + 10).Copy 'SD
        masterWS.Range("H:H" & counter).PasteSpecial xlPasteAll

        masterWS.Range("I:I" & counter).Value = "TEST"

    End If

    If counter2 > 0 Then
        counter = counter - counter2
        WS2.Range("E11:E" & counter2 + 10).Copy 
        masterWS.Range("B:B" & counter).PasteSpecial xlPasteAll

        WS2.Range("I11:I" & counter2 + 10).Copy 
        masterWS.Range("C:C" & counter).PasteSpecial xlPasteAll

        WS2.Range("J11:J" & counter2 + 10).Copy 'AMOUNT
        masterWS.Range("D:D" & counter).PasteSpecial xlPasteAll

        WS2.Range("K11:K" & counter2 + 10).Copy 'PRICE
        masterWS.Range("E:E" & counter).PasteSpecial xlPasteAll

        WS2.Range("S11:S" & counter2 + 10).Copy 'BROKER
        masterWS.Range("F:F" & counter).PasteSpecial xlPasteAll

        WS2.Range("B11:B" & counter2 + 10).Copy 'TD
        masterWS.Range("G:G" & counter).PasteSpecial xlPasteAll

        WS2.Range("C11:C" & counter2 + 10).Copy 'SD
        masterWS.Range("H:H" & counter).PasteSpecial xlPasteAll

        masterWS.Range("I:I" & counter).Value = "test2"


    End If
Wend





Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

Answer 1

Мне удалось успешно сделать эту работу. Приведенный ниже код берет данные из 5 отдельных таблиц на разных листах и ​​сохраняет их в одной таблице.

        ' -- Merges sheets to one table -- '
    Sub merge()
        Dim wb As Workbook:         Set wb = Workbooks("MASTER.xlsm")
        Dim masterWS As Worksheet:  Set masterWS = wb.Worksheets("MASTER")
        Dim WS1 As Worksheet:     Set WS1 = wb.Worksheets("1")
        Dim WS2 As Worksheet:    Set WS2 = wb.Worksheets("2")
        Dim WS3 As Worksheet:    Set WS3 = wb.Worksheets("3")
        Dim WS4 As Worksheet:    Set WS4 = wb.Worksheets("4")
        Dim WS5 As Worksheet:     Set WS5 = wb.Worksheets("5")
        Dim WSArray As Variant
        Dim currentWS As Worksheet

        Dim counter1 As Long
        Dim counter2 As Long
        Dim counter3 As Long
        Dim counter4 As Long
        Dim counter5 As Long
        Dim counter As Long
        Dim tempCounter As Long

        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.DisplayAlerts = False

        ' Count rows for each account
        WS1.Activate
        counter1 = Workbooks("MASTER.xlsm").Worksheets("1").Range("A11", Range("A11").End(xlDown)).Rows.Count
        WS2.Activate
        counter2 = Workbooks("MASTER.xlsm").Worksheets("2").Range("A11", Range("A11").End(xlDown)).Rows.Count
        WS3.Activate
        counter3 = Workbooks("MASTER.xlsm").Worksheets("3").Range("A11", Range("A11").End(xlDown)).Rows.Count
        WS4.Activate
        counter4 = Workbooks("MASTER.xlsm").Worksheets("4").Range("A11", Range("A11").End(xlDown)).Rows.Count
        WS5.Activate
        counter5 = Workbooks("MASTER.xlsm").Worksheets("5").Range("A11", Range("A11").End(xlDown)).Rows.Count

        ' Sum of counter
        counter = counter1 + counter2 + counter3 + counter4 + counter5 + 2

        WSArray = Array("1", "2", "3", "4", "5")

        For Each currentWSName In WSArray
            Set currentWS = wb.Worksheets(currentWSName)

            currentWS.Activate

            If IsEmpty(currentWS.Range("A12").Value) = True And IsEmpty(currentWS.Range("A11")) = False Then
                tempCounter = 1
            Else
                tempCounter = currentWS.Range("A11", Range("A11").End(xlDown)).Rows.Count
            End If


            counter = (counter - tempCounter)

            If IsEmpty(currentWS.Range("A11").Value) = False Then
                currentWS.Range("E11:E" & tempCounter + 10).Copy 'ISIN
                masterWS.Range("B" & counter).PasteSpecial xlPasteAll

                currentWS.Range("I11:I" & tempCounter + 10).Copy 'B/S
                masterWS.Range("C" & counter).PasteSpecial xlPasteAll

                currentWS.Range("J11:J" & tempCounter + 10).Copy 'AMOUNT
                masterWS.Range("D" & counter).PasteSpecial xlPasteAll

                currentWS.Range("K11:K" & tempCounter + 10).Copy 'PRICE
                masterWS.Range("E" & counter).PasteSpecial xlPasteAll

                currentWS.Range("S11:S" & tempCounter + 10).Copy 'BROKER
                masterWS.Range("F" & counter).PasteSpecial xlPasteAll

                currentWS.Range("B11:B" & tempCounter + 10).Copy 'TD
                masterWS.Range("G" & counter).PasteSpecial xlPasteAll

                currentWS.Range("C11:C" & tempCounter + 10).Copy 'SD
                masterWS.Range("H" & counter).PasteSpecial xlPasteAll

                masterWS.Range("I" & counter & ":I" & (tempCounter + counter) - 1).Value = currentWSName
            End If

            Next currentWSName



        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.DisplayAlerts = True

    End Sub

Answer 2

Вы можете использовать al oop, чтобы справиться с этим. Инициализируйте список рабочих листов, с которыми вы хотите скопировать / вставить код, а затем выполните итерации по этим рабочим листам.

Dim WSArray As Variant
Dim currentWS As Worksheet
WSArray = Array("WSName1", "WSName2", "WSName3", "WSName4", "WSName5")

For Each currentWSName In WSArray
    Set currentWS = wb.Worksheets(currentWSName)
    ' Copy Pasted Code Goes here, but reference currentWS instead of WS1 etc