Excel 将不同列中的值相互复制

嗨，我有一张如下所示的桌子：

  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个条目之后，应获取一个新行，直到选定区域通过。我已经试过了，但效果并不理想：他总是把所有的东西都写在同一列，而不是在两列的下面。 这是我到目前为止的代码…：

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

Sub-ZusammenfassungKosten（）
将ws1标注为工作表，将ws2标注为工作表
调暗rg1作为范围，rg2作为范围，rg3作为范围
尺寸v1、v2、n1、n2与长度相同
Dim xAdr作为字符串
n1=-1
设置ws1=Tabelle2
设置ws2=Tabelle3
设置rg1=ws1.范围（“A3:F10000”）
设置rg2=ws2.范围（“Q2”）
rg2.调整大小（30000，2）.ClearContents
设置rg3=rg1.Find（“*”，ws1.Range（“F10000”），xlValues，xlPart，xlByRows，xlNext）
如果不是（rg3什么都不是），那么
xAdr=rg3.地址
做
n1=n1+1
rg2.偏移量（n1，0）.值=rg3.值
设置rg3=rg1.FindNext（rg3）
在xAdr rg3.Address时循环
如果结束
设置rg3=无
设置rg2=无
设置rg1=无
设置ws=Nothing
端接头

---

非常感谢您的支持

在我看来，每个循环需要两次找到下一个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

Sub-ZusammenfassungKosten（）
将ws1标注为工作表，将ws2标注为工作表
调暗rg1作为范围，rg2作为范围，rg3作为范围
尺寸v1、v2、n1、n2与长度相同
Dim xAdr作为字符串
n1=-1
设置ws1=Tabelle2
设置ws2=Tabelle3
设置rg1=ws1.范围（“A3:F10000”）
设置rg2=ws2.范围（“Q2”）
rg2.调整大小（30000，2）.ClearContents
设置rg3=rg1.Find（“*”，ws1.Range（“F10000”），xlValues，xlPart，xlByRows，xlNext）
如果不是（rg3什么都不是），那么
xAdr=rg3.地址
做
n1=n1+1
rg2.偏移量（n1，0）.值=rg3.0
设置rg3=rg1.FindNext（rg3）
rg2.偏移量（n1，1）.值=rg3.value
设置rg3=rg1.FindNext（rg3）
在xAdr rg3.Address时循环
如果结束
设置rg3=无
设置rg2=无
设置rg1=无
设置ws=Nothing
端接头