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

将值从不同的列复制到彼此

1 个答案: