Копирование значений из разных столбцов друг в друга

Question

Привет, у меня есть таблица, похожая на следующую:

  A    B      C      D            E          F
|7B | 3,27  | 72 |  4,55    |       |         |
|7C | 0,46  | 73 |  0,53    |   CF  |   0,81  |
|7D | 0,46  | 74 |  0,54    |   CG  |   0,79  |
|7H | 0,47  | 76 |  0,54    |   CJ  |   0,77  |
|   |       |    |          |   CL  |   0,61  |
|7K | 0,48  | 77 |  0,57    |   CM  |   0,49  |
|7L | 0,44  | 78 |  0,53    |   CN  |   0,43  |
|7N | 0,73  |    |          |       |         |     
|7P | 0,64  |    |          |       |         | 
|7O | 0,71  |    |          |       |         |  
|   |       | 75 |  0,85    |       |         | 

Ожидаемый результат:

|7B| 3,27 |
|72| 4,55 |
|7C| 0,46 |
|73| 0,53 |
|CF| 0,81 |
...
|75| 0,85 |

Я бы хотел, чтобы записи отдельных столбцов всегда вводились парами один за другим в 2 столбца (на другом листе). После каждых 2 записей, новая строка должна быть взята, пока выбранная область не прошла. Я уже что-то пробовал, но это не работает должным образом: он всегда пишет все в одном столбце, а не в 2 столбцах друг под другом. Это код, который у меня есть ...:

Sub ZusammenfassungKosten()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim rg1 As Range, rg2 As Range, rg3 As Range
Dim v1, v2, n1, n2 As Long
Dim xAdr As String

n1 = -1

Set ws1 = Tabelle2
Set ws2 = Tabelle3
Set rg1 = ws1.Range("A3:F10000")
Set rg2 = ws2.Range("Q2")

rg2.Resize(30000, 2).ClearContents

Set rg3 = rg1.Find("*", ws1.Range("F10000"), xlValues, xlPart, xlByRows, xlNext)
If Not (rg3 Is Nothing) Then

xAdr = rg3.Address
Do
n1 = n1 + 1
rg2.Offset(n1, 0).Value = rg3.Value

Set rg3 = rg1.FindNext(rg3)
Loop While xAdr <> rg3.Address
End If


Set rg3 = Nothing
Set rg2 = Nothing
Set rg1 = Nothing
Set ws = Nothing



End Sub

Большое спасибо за вашу поддержку!

Answer 1

Похоже, вам нужно дважды найти следующее значение rg3 за цикл - и записать результаты в два столбца. Надеюсь, это то, что вы после:

Sub ZusammenfassungKosten()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rg1 As Range, rg2 As Range, rg3 As Range
    Dim v1, v2, n1, n2 As Long
    Dim xAdr As String

    n1 = -1

    Set ws1 = Tabelle2
    Set ws2 = Tabelle3
    Set rg1 = ws1.Range("A3:F10000")
    Set rg2 = ws2.Range("Q2")

    rg2.Resize(30000, 2).ClearContents

    Set rg3 = rg1.Find("*", ws1.Range("F10000"), xlValues, xlPart, xlByRows, xlNext)
    If Not (rg3 Is Nothing) Then

        xAdr = rg3.Address
        Do
            n1 = n1 + 1
            rg2.Offset(n1, 0).value = rg3.value

            Set rg3 = rg1.FindNext(rg3)
            rg2.Offset(n1, 1).value = rg3.value

            Set rg3 = rg1.FindNext(rg3)

        Loop While xAdr <> rg3.Address
    End If


    Set rg3 = Nothing
    Set rg2 = Nothing
    Set rg1 = Nothing
    Set ws = Nothing



End Sub