VBA:复制和转置粘贴,但在每个值

时间:2018-04-03 10:53:27

标签: excel vba excel-vba

我需要帮助一些人,我对此非常感兴趣。我想复制一些数据行,如下图所示。 数据来源示例: Example of the source of the data

我想转置此数据并将其粘贴到另一张纸上,如下一个链接后的图片所示。这是期望的结果。 I filled this sheet manually.

困难的部分是每行粘贴到一列后,需要跳过一个列。这是我得到的代码。此代码会跳过它应该的列,但数据不会以正确的方式粘贴 - 正如您在下面的示例中所看到的。结果/粘贴表the actual result of the CODE below

的示例 我很坚持这个。谁知道我怎么解决这个问题?非常感谢帮助。

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

2 个答案:

答案 0 :(得分:1)

这是使用变体数组的方法。

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

答案 1 :(得分:0)

使用End(xlUp)令人困惑。

只需替换

ThisWorkbook.Sheets("SLA").Range("B6").End(xlUp).Offset(4, (x - 2) * 2).PasteSpecial xlPasteValues

ThisWorkbook.Sheets("SLA").Range("B6").Offset(0, (x - 2) * 2).PasteSpecial xlPasteValues