Сложить несколько столбцов в два столбца в парах по два

Question

У меня есть столбцы A:ALC, заполненные данными, и для каждого столбца имеется различное количество строк.Если возможно, мне нужен макрос, который будет складывать столбцы в парах по два.Например, столбец C непосредственно под столбцом A и столбец D непосредственно под столбцом B и т. Д. Для всех столбцов A:ALC.

        COLUMN A    COLUMN B          COLUMN C      COLUMN D
ROW 1   2598        F800              2599          F800
ROW 2   2598        K1300             2599          K1300
ROW 3   2598        S1000RR           2599          R900
ROW 4   2598        G650              2599          G650
ROW 5   2598        R1200             2599          K1600
ROW 6   2599        S1000
ROW 7   2599        HP2
ROW 8   2599        R1200

Для каждой пары столбцов имеется одинаковое количество данных (например, столбцы A и B имеют 8 строк, столбцы C и D имеют 5 строк и т. Д.), но количество строк, очевидно, различается между многими парами столбцов.В данных отсутствуют пробелы.

Когда я запустил макрос, вы дали Excel отобразить это:

Ошибка времени выполнения '13': Несовпадение типов

В чем может быть проблема?

ПРИМЕЧАНИЕ : в некоторых столбцах есть только пара данных, то есть данные только в первой строке.

Это то, что мне нужно, чтобы вывод был похож:

       COLUMN A    COLUMN B          
ROW 1   2598        F800              
ROW 2   2598        K1300             
ROW 3   2598        S1000RR 
ROW 4   2598        G650              
ROW 5   2598        R1200             
ROW 6   2599        S1000
ROW 7   2599        HP2
ROW 8   2599        R1200
ROW 9   2599        F800
ROW 10  2599        K1300
ROW 11  2599        R900
ROW 12  2599        G650
ROW 13  2599        K1600

Answer 1

Если ваш диапазон данных от A: ALC заполнен, то этот вариант кода массива очень быстро сформирует ваш новый диапазон в столбцах A и B

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

[Обновлено для обработки пустых диапазонов и / или отдельных ячеек]

Sub Combine()
Dim OrigA
Dim OrigB
Dim strA As String
Dim strB As String
Dim strDelim As String
Dim lngCol As Long

strDelim = "||"
strA = Join(Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp))), strDelim)
strB = Join(Application.Transpose(Range([b1], Cells(Rows.Count, "b").End(xlUp))), strDelim)

For lngCol = Columns("C").Column To Columns("ALC").Column - 2 Step 2
    If Application.CountA(Columns(lngCol)) > 1 Then
    'handle odd column range
        strA = strA & (strDelim & Join(Application.Transpose(Range(Cells(1, lngCol), Cells(Rows.Count, lngCol).End(xlUp))), strDelim))
    Else
    'handle odd column single cell
        If Len(Cells(1, lngCol)) > 0 Then strA = strA & (strDelim & Cells(1, lngCol).Value)
    End If
      If Application.CountA(Columns(lngCol + 1)) > 1 Then
      'handle even column range
    strB = strB & (strDelim & Join(Application.Transpose(Range(Cells(1, lngCol + 1), Cells(Rows.Count, lngCol + 1).End(xlUp))), strDelim))
    Else
     'handle even column single cell
    If Len(Cells(1, lngCol + 1)) > 0 Then strB = strB & (strDelim & Cells(1, lngCol + 1).Value)
    End If
Next

OrigA = Application.Transpose(Split(strA, strDelim))
OrigB = Application.Transpose(Split(strB, strDelim))

[a1].Resize(UBound(OrigA, 1), 1) = OrigA
[b1].Resize(UBound(OrigB, 1), 1) = OrigB

End Sub