Консолидация построчно из разных листов с разным количеством записей в основной лист

Question

У меня есть несколько рабочих листов, количество строк в которых варьируется на каждом листе, но имена столбцов одинаковы. Как добавить строку за строкой (означает, что 1-я строка начинается с 1-го листа, затем 2-я строка должна добавляться так, как если бы она была 2-й) лист, и 3-я строка добавляется таким образом, который идет с 3-го листа и продолжается) в основной лист, который содержит все строки по одной, полученные из нескольких листов. Может ли кто-нибудь помочь мне в этом вопросе Спасибо заранее!

Answer 1

StackOverflow не является службой «напиши мой код для меня».

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

Он также не проверяет, вводится ли имя листа, которого еще не существует, и выдает ошибку, если вы введете существующее имя.

Эта версия предполагает, что каждая вкладка имеет заголовки и исключает первую строку на последующих вкладках:

Public Sub MergeTabs()

'Merges selected tabs (or all visible tabs if only 1 selected) in current workbook into a new tab

Dim i As Integer, wb As Workbook, w As Window, wsTo As Worksheet, wsFrom As Collection   'Worksheet collection
Dim strScope As String, strNewTab As String
Dim raTarget As Range

Set wb = ActiveWorkbook
Set w = ActiveWindow

Set wsFrom = New Collection

If w.SelectedSheets.Count = 1 Then
    For i = 1 To wb.Worksheets.Count
        If wb.Worksheets(i).Visible Then wsFrom.Add wb.Worksheets(i)
    Next
    strScope = "ALL VISIBLE"
Else
    For i = 1 To w.SelectedSheets.Count
        If w.SelectedSheets(i).Visible Then wsFrom.Add w.SelectedSheets(i)
    Next
    strScope = wsFrom.Count & " SELECTED"
End If

strNewTab = InputBox("Merge data from " & strScope & " sheets to new sheet named:", "Merge tabs", "All")
If strNewTab = vbNullString Then Exit Sub

Set wsTo = wb.Worksheets.Add(wsFrom(1), Count:=1) 'Add before first selected sheet
wsTo.Name = strNewTab

wsFrom(1).Range("A1").CurrentRegion.Copy
wsTo.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False

For i = 2 To wsFrom.Count
    wsFrom(i).Range("A2", wsFrom(i).Range("A1").CurrentRegion.Cells(wsFrom(i).Range("A1").CurrentRegion.Cells.Count)).Copy
    wsTo.Cells(wsTo.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    Application.CutCopyMode = False
Next i

wsTo.Range("A1").Select

MsgBox "Merge Done"

End Sub

В этой версии предполагается, что заголовки отсутствуют (или только заголовки на первой вкладке) ):

Public Sub MergeTabs()

'Merges selected tabs (or all visible tabs if only 1 selected) in current workbook into a new tab

Dim i As Integer, wb As Workbook, w As Window, wsTo As Worksheet, wsFrom As Collection   'Worksheet collection
Dim strScope As String, strNewTab As String
Dim raTarget As Range

Set wb = ActiveWorkbook
Set w = ActiveWindow

Set wsFrom = New Collection

If w.SelectedSheets.Count = 1 Then
    For i = 1 To wb.Worksheets.Count
        If wb.Worksheets(i).Visible Then wsFrom.Add wb.Worksheets(i)
    Next
    strScope = "ALL VISIBLE"
Else
    For i = 1 To w.SelectedSheets.Count
        If w.SelectedSheets(i).Visible Then wsFrom.Add w.SelectedSheets(i)
    Next
    strScope = wsFrom.Count & " SELECTED"
End If

strNewTab = InputBox("Merge data from " & strScope & " sheets to new sheet named:", "Merge tabs", "All")
If strNewTab = vbNullString Then Exit Sub

Set wsTo = wb.Worksheets.Add(wsFrom(1), Count:=1) 'Add before first selected sheet
wsTo.Name = strNewTab

wsFrom(1).Range("A1").CurrentRegion.Copy
wsTo.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False

For i = 2 To wsFrom.Count
    wsFrom(i).Range("A1").CurrentRegion.Copy
    wsTo.Cells(wsTo.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    Application.CutCopyMode = False
Next i

wsTo.Range("A1").Select

MsgBox "Merge Done"

End Sub