☰

Объединить 2 столбца на отдельных листах в один столбец

tag-icon • tag-icon microsoft-excel worksheet-function vba
Объединить 2 столбца на отдельных листах в один столбец

У меня есть 2 списка на двух отдельных листах, и я пытаюсь объединить их в третий лист. Эти списки автоматически заполняются на основе ввода пользователя, поэтому количество строк в списке может меняться. Поэтому, как только он ничего не обнаруживает в первом столбце листа 1, он начинает заполнять список на листе 3 столбцами листа 2, вот так

Лист 1

Make    Model     License Plate
Ford    Escape    UVC345
Honda   Civic     KD2YR9

Лист 2

Make    Model    License Plate 
Dodge   Charger  34TRLS2
VW      Passat   V70YTR

Лист 3

Make    Model    License Plate
Ford    Escape   UVC345
Honda   Civic    KD2YR9
Dodge   Charger  34TRLS2
VW      Passat   V70YTR

Обновлять:

Проблема, с которой я сталкиваюсь при использовании VBA для копирования и вставки, заключается в том, что он вставляет и определяет формулы, которые используются для автоматического заполнения исходного списка на листе 1. Поскольку он вставляет формулы, он неправильно определяет, где находится последняя ячейка на листе 3.

Sub Copy_Alternatives()

Worksheets("CNA eTool Alternatives").Range("A:A").Copy
Worksheets("Repair Replacement Recom").Range("A:A").PasteSpecial xlPasteValues
Worksheets("CNA eTool Alternatives").Range("B:B").Copy
Worksheets("Repair Replacement Recom").Range("B:B").PasteSpecial xlPasteValues
Worksheets("CNA eTool Alternatives").Range("C:C").Copy
Worksheets("Repair Replacement Recom").Range("C:C").PasteSpecial xlPasteValues

End Sub

Sub Copy_Paste_Range()

Dim lNewRow As Long
Dim lDataRow As Long

ThisWorkbook.Activate

lNewRow = Worksheets("CNA eTool Addit. Alternatives").Cells(Worksheets("CNA eTool Addit. Alternatives").Rows.Count, "H").End(xlUp).Row

lDataRow = Worksheets("Repair Replacement Recom").Cells(Worksheets("Repair Replacement Recom").Rows.Count, 1).End(xlUp).Row
lDataRow = lDataRow + 1

Worksheets("CNA eTool Addit. Alternatives").Range("H2:J" & lNewRow).Copy
Worksheets("Repair Replacement Recom").Range("A" & lDataRow).PasteSpecial

End Sub

решение1

Это можно сделать с помощью функций рабочего листа.

Допустим, ваш первый лист — это Sheet1, а второй — этоExtra1

Поместите следующую формулу на объединенный лист A2, затем скопируйте и вставьте в другие ячейки:

=IF(ROW()>COUNTA(Sheet1!A:A)+COUNTA(Extra1!A:A)-1,"",INDIRECT(IF(ROW()<=COUNTA(Sheet1!A:A),"Sheet1!","Extra1!")&SUBSTITUTE(ADDRESS(1,COLUMN(),4),1,"")&ROW()-IF(ROW()<=COUNTA(Sheet1!A:A),0,COUNTA(Sheet1!A:A)-1)))

Как это работает:

  1. Проверяет, больше ли текущая строка, чем количество строк на первом листе + второй лист минус один (потому что оба имеют заголовки);
  2. Если текущая строка больше, показать пустую. Иначе перейти к следующему шагу;
  3. Подготавливает INDIRECT. Если текущая строка ниже строк на первом листе, получает имя первого листа. В противном случае получает имя второго листа;
  4. Он использует SUBSTITUTE + ADDRESSтрюк, чтобы вернуть текущую букву столбца. Это хорошо, потому что тогда он использует ту же формулу для всех полей, и принимает даже когда столбец становится AA
  5. Наконец, он получает текущую строку, если текущая строка меньше количества элементов на первом листе, в противном случае он получает текущую строку МИНУС количество строк первого листа, минус один, чтобы вернуть начальную строку листа два.

Я знаю, что это немного утомительно и трудно для чтения, но формулы иногда лучше, чем VBA.

Редактировать: Ну что ж, у меня было озарение, и я получил работающую версию VBA.

Sub merge()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws1 = Sheets("Sheet1") 'First sheet to get merged
Set ws2 = Sheets("Extra1") 'Second sheet to get merged
Set ws3 = Sheets("Merged") 'Name of the sheet you want results
Dim lr As Long 'To return the number of the last row
Dim arrayone As Variant
lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row
arrayone = Range(ws1.Cells(2, 1), ws1.Cells(lr, 3)).Value 'From Row 2 onwards, considering it has headers
Dim arr2 As Variant
lr = ws2.Cells(Rows.Count, 1).End(xlUp).Row
arr2 = Range(ws2.Cells(2, 1), ws2.Cells(lr, 3)).Value 'From Row 2 onwards, considering it has headers
Dim arr3 As Variant
ReDim arr3(1 To UBound(arrayone, 1) + UBound(arr2, 1), 1 To 3)
For i = 1 To UBound(arr3, 1)
    For j = 1 To 3
        If i <= UBound(arrayone, 1) Then
            arr3(i, j) = arrayone(i, j)
        Else
            arr3(i, j) = arr2(i - UBound(arrayone, 1), j)
        End If
    Next j
Next i
Range(ws3.Cells(2, 1), ws3.Cells(UBound(arr3) + 1, 3)).Value = arr3
End Sub

Связанный контент