如何解决如何在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
感谢大家的帮助。
解决方法
请尝试下一个代码。对于大范围,它应该非常快。它避免了每行之间的迭代,它使用数组和数组切片:
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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。