VBA循环复制粘贴一个列与另一个工作表中的列多次

Question

我试图在VBA Excel中开发一个循环，从数据透视表复制和粘贴第一列与此数据透视表中所有列的数量一样多(如果我有62列，我需要复制粘贴第一列61次在另一个sheet2中的一列)。我需要将其他61列与sheet2中第三列的每个列的标题一起复制到一列中。

Sub SelCopCol()
Dim ss As String
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim NC As Long

Set wb = ThisWorkbook
Set ws1 = wb.Worksheets(sheet1_Pivot)
Set ws2 = wb.Worksheets(sheet2)

'Define the range of rows 
ss = ws1.Range("A:A").Find("Grand Total", ws1.Cells(1, 1)).Row
NC = ws1.Cells(1, Columns.Count).End(xlToLeft).Column


Application.ScreenUpdating = False
For i = 2 To NC
ws2.Range("C2:C" & ss - 1) = ws1.Range("A2:A" & ss - 1).Value
ws2.Range("H2:H" & ss - 1) = ws1.Range("B2:B" & ss - 1).Value 
ws2.Range("M2:M" & ss - 1) = ws1.Range("B1").Value
'I should use a variables for "B2:B" and "B1" but I couldn't 
Next i
Application.ScreenUpdating = True

End Sub

Answer 1

有一种方法:

Sub SelCopCol()

Dim ss As Long '<< not string
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim numRows As Long, NC As Long, rng As Range, rng2 As Range, rngDest As Range

Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("sheet1_Pivot")
Set ws2 = wb.Worksheets("sheet2")

NC = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
ss = ws1.Range("A:A").Find("Grand Total", ws1.Cells(1, 1)).Row

Set rng = ws1.Range("A2:A" & ss - 1)          'row labels
numRows = rng.Rows.Count
Set rng2 = rng.Offset(0, 1)                  'first data column
Set rngDest = ws2.Range("C2").Resize(numRows) 'first "paste" destination

Application.ScreenUpdating = False
Do While rng2.Column <= NC     'until we reach the last column
'copy values
rngDest.Value = rng.Value
rngDest.EntireRow.Columns("H").Value = rng2.Value
rngDest.EntireRow.Columns("M").Value = ws1.Cells(1, rng2.Column).Value

Set rng2 = rng2.Offset(0, 1)          'one column over
Set rngDest = rngDest.Offset(numRows) 'move destination range down
Loop
Application.ScreenUpdating = True
End Sub