时间戳

首页 > 解决方案 > 将不同列中的值相互复制

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 个条目后，应取一个新行，直到所选区域通过。我已经尝试了一些东西，但它没有按预期工作：他总是将所有内容写在同一列中，而不是在彼此下方的 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

多谢您的支持！

标签： excelvba

解决方案

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

推荐阅读