объединить данные с другим заголовком

Question

У меня несколько листов, большинство из которых имеют одинаковый заголовок, но один (1) лист имеет другой заголовок

У меня есть этот код, который объединит их все

Sub combined()

Dim xWs As Worksheet
On Error Resume Next

Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
xWs.name = "Combined"
Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
For i = 2 To Worksheets.Count
    Worksheets(i).Range("A1").CurrentRegion.Offset(1, 0).Copy _
           Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)

Next

Dim s As Worksheet, t As String
Dim j As Long, K As Long
K = Sheets.Count

For j = K To 1 Step -1
    t = Sheets(j).name
    If t <> "Combined" Then
        Application.DisplayAlerts = False
            Sheets(j).Delete
        Application.DisplayAlerts = True
    End If
Next j

End Sub

это работает хорошо, но я хочу, чтобы мой 1 лист был вставлен в столбец D до последнего столбца

sheet3 не содержит первые 3 столбца другого примера листа

лист1, лист2 и лист 4 содержат эти столбцы

Branch | Population | Store | name | age | ...

в то время как лист 3 содержит

name | age | ...

остальные одинаковые только на первых 3 столбцах нет. Я не то, что я собираюсь добавить в код, чтобы вставить его в назначенный столбец.

о, они содержат разные значения данных

Спасибо!

Answer 1

Простой и не очень динамичный способ сделать это - изменить процедуру копирования для sheet3. Просто добавив if в цикл следующим образом:

For i = 2 To Worksheets.Count
    If i <> 4 Then
        Worksheets(i).Range("A1").CurrentRegion.Offset(1, 0).Copy _
           Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
    Else
        Worksheets(i).Range("A1").CurrentRegion.Offset(1, 0).Copy _
           Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 4)

    End If
Next i

Это сдвигает всю "вставку" части 3 столбца для листа 3.

В зависимости от того, как столбцы могут измениться для других листов, вы можете подсчитать столбцы и соответственно сместить их, даже без использования оператора if .

Если столбцы всегда отсутствуют слева направо, а Sheet1 используется в качестве основы для определения размера таблицы (как в этом коде), вы можете сделать что-то более динамичное, например:

Dim xWs As Worksheet, i As Long, lCol As Long, mCol As Long

Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
xWs.Name = "Combined"
mCol = Worksheets(2).Cells(1, Columns.Count).End(xlToLeft).Column + 1
Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
For i = 2 To Worksheets.Count
        lCol = Worksheets(i).Cells(1, Columns.Count).End(xlToLeft).Column
        Worksheets(i).Range("A1").CurrentRegion.Offset(1, 0).Copy _
           Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, mCol - lCol)
Next i

Или что-то более продвинутое и сравнивающее название каждого столбца.