CODEWITHSUNDEEP
excelvba
Riced
Riced

Reputation: 35

Copying Values from Different Columns to Each Other

Hi I have a table looking like the following: 

  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    |       |         |

Expected Result:

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

I would like to have the entries of the individual columns always entered in pairs one after the other in 2 columns (in another worksheet). After every 2 entries, a new row should be taken until the selected area has passed through. I already tried something, but it doesn't work as desired: he always writes everything in the same column and not in 2 columns below each other. This is the code I have so far...:

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

Thank´s a lot for your support!

Upvotes: 0

Views: 49

Answers (1)

BZngr
BZngr

Reputation: 681

Looks to me like you need to Find the next rg3 value twice per loop - and write the results out to two columns. Hope this is what you are after:

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

Upvotes: 1

Related Questions