VBA: Copy and transpose paste but skip one column after every value

Question

I need some help guys, I am so stuck on this. I want to copy some rows of data which are displayed as shown in the image below. Example of the source of the data:

I want to transpose this data and paste it to another sheet, as shown in the image following the next link. This is the desired result. I filled this sheet manually.

The difficult part is that after every row is pasted in to a column, a colum needs to be skipped. This is the code I got. This code skips a column like it should, but the data is not pasted in the correct way - as you can see in the following example. Example of the result/paste sheet

Im so stuck on this. Somebody who knows how I can tackle this? Help is much appreciated.

Dim iLastRow As Integer

'vind laatste rij
iLastRow = ThisWorkbook.Sheets("Mappen_Outlook").Cells(Rows.Count, 1).End(xlUp).Row

For x = 2 To iLastRow

'kopieer submap 3 vanuit mappen naar SLA
ThisWorkbook.Sheets("Mappen_Outlook").Range("D" & x & ":D" & x).Copy
ThisWorkbook.Sheets("SLA").Range("B2").End(xlUp).Offset(1, (x - 2) * 2).PasteSpecial xlPasteValues

'kopieer de oudste datum vanuit mappen naar SLA
ThisWorkbook.Sheets("Mappen_Outlook").Range("G" & x & ":G" & x).Copy
ThisWorkbook.Sheets("SLA").Range("B3").End(xlUp).Offset(1, (x - 2) * 2).PasteSpecial xlPasteValues

'kopieer de totaalmails vanuit mappen naar SLA
ThisWorkbook.Sheets("Mappen_Outlook").Range("E" & x & ":E" & x).Copy
ThisWorkbook.Sheets("SLA").Range("B4").End(xlUp).Offset(2, (x - 2) * 2).PasteSpecial xlPasteValues

'kopieer het aantal op SLA vanuit mappen naar SLA
ThisWorkbook.Sheets("Mappen_Outlook").Range("I" & x & ":I" & x).Copy
ThisWorkbook.Sheets("SLA").Range("B5").End(xlUp).Offset(3, (x - 2) * 2).PasteSpecial xlPasteValues

'kopieer het aantal buiten SLA vanuit mappen naar SLA
ThisWorkbook.Sheets("Mappen_Outlook").Range("J" & x & ":J" & x).Copy
ThisWorkbook.Sheets("SLA").Range("B6").End(xlUp).Offset(4, (x - 2) * 2).PasteSpecial xlPasteValues

Next x

I don't quite understand what the problem is with your code (what does "not in the correct way" mean?)... can you append the result of your code? — dv3
My post was a bit vague! I added a image the desired result (which i filled manually). The code skips a row for some reason... — Thomas de Ruiter

Dy.Lee Dy.Lee · Accepted Answer · 2018-04-03T13:28:33

This is method of using variant array.

Sub test()
    Dim vDB, vR() 
    Dim Ws As Worksheet, toWs As Worksheet
    Dim i As Long, n As Long

    Set Ws = Sheets("Mappen_Outlook")
    Set toWs = Sheets("SLA")

    vDB = Ws.Range("a1").CurrentRegion

    For i = 2 To UBound(vDB, 1)
        n = n + 2
        ReDim Preserve vR(1 To 8, 1 To n)
        vR(1, 1) = vDB(1, 4)
        vR(2, 1) = vDB(1, 7)
        vR(4, 1) = vDB(1, 5)
        vR(5, 1) = vDB(1, 9)
        vR(8, 1) = vDB(1, 10)

        vR(1, n) = vDB(i, 4)
        vR(2, n) = vDB(i, 7)
        vR(4, n) = vDB(i, 5)
        vR(5, n) = vDB(i, 9)
        vR(8, n) = vDB(i, 10)
    Next i
    With toWs
        .Cells.Clear
        .Range("a2").Resize(8, n) = vR
    End With
End Sub

VBA: Copy and transpose paste but skip one column after every value

2 Answers