时间戳

首页 > 解决方案 > 如何复制一组列并将它们放在VBA中的一组行中

excel - 如何复制一组列并将它们放在VBA中的一组行中

问题描述

我正在尝试执行以下操作（请参见下图）：我在工作表中有 N 个类别（下面仅显示 2 个作为示例），每个类别有 5 个子类别，我想将它们复制到另一个工作表中但只有子类别，列出来自其他类别的所有数据。我怎么能在 VBA 中做到这一点？

在此处输入图像描述

到目前为止我使用的代码：

    Sub Fill_Tracker()

    ' Initialize the worksheets, number of rows per Offer and numbers of Offers
    Dim WSS As Worksheet
    Dim WSD As Worksheet
    Set WSS = Sheets("Database")
    Set WSD = Sheets("Data_PIVOT")
' Copy and paste values of Currency BOQ
    WSS.Range("B10", WSS.Range("b10").End(xlDown)).Copy
    WSD.Range("J2").PasteSpecial xlPasteValues
    ' Copy and paste values of USD
    WSS.Range("c10", WSS.Range("c10").End(xlDown)).Copy
    WSD.Range("k2").PasteSpecial xlPasteValues
    ' Copy and paste values of USD/Wdc
    WSS.Range("d10", WSS.Range("d10").End(xlDown)).Copy
    WSD.Range("l2").PasteSpecial xlPasteValues
    ' Copy and paste values of Rate
    WSS.Range("e10", WSS.Range("e10").End(xlDown)).Copy
    WSD.Range("m2").PasteSpecial xlPasteValues
    ' Copy and paste values of Description
    WSS.Range("f10", WSS.Range("f10").End(xlDown)).Copy
    WSD.Range("n2").PasteSpecial xlPasteValues

感谢所有的帮助。

标签： excelvbacopypaste

解决方案

请尝试下一个代码。对于大范围，它应该非常快。它避免了每一行之间的迭代，它使用数组和数组切片：

Sub Fill_Tracker()
    Dim WSS As Worksheet, WSD As Worksheet, lastRow As Long, lastCol As Long, lastR As Long
    Dim arr, arrCateg, strC As String, strCol As String, i As Long, lastRWSD As Long, c As Long
    
    Set WSS = Sheets("Database")
    Set WSD = Sheets("Data_PIVOT")
    lastRow = WSS.UsedRange.Rows.count 'maximum number of rows to be processed
    lastCol = WSS.cells(2, WSS.Columns.count).End(xlToLeft).Column 'no of columns
    lastRWSD = WSD.Range("A" & WSD.Rows.count).End(xlUp).row + 1   'last empty row
       
    arr = WSS.Range("A3", WSS.cells(lastRow, lastCol)).Value 'put the sheet content in an array
    c = 5  'a variable to increment in order to build the column to be copied headers
    For i = 1 To UBound(arr, 2) Step 5
        strC = Split(cells(1, i).Address, "$")(1)                  'first column letter
        strCol = strC & ":" & Split(cells(1, c).Address, "$")(1)   'string of involved columns letter
        lastR = WSS.Range(strC & WSS.Rows.count).End(xlUp).row - 2 'last row for the above range
        
        c = c + 5 'increment the columns range
        'make a slice for the necessary array rows and columns!
        arrCateg = Application.index(arr, Evaluate("row(1:" & lastR & ")"), Evaluate("COLUMN(" & strCol & ")"))
        'drop the array at once:
        WSD.Range("A" & lastRWSD).Resize(UBound(arrCateg), 5).Value = arrCateg
        lastRWSD = WSD.Range("A" & WSD.Rows.count).End(xlUp).row + 1 'last row where next time the array will be dropped
    Next
End Sub

推荐阅读