Question

运行我编写的用于转置数据集的VBA宏时出现问题。主要目标是逐行获取此数据集，并将其转置，以便列B：K为新行。

以下是我想要做的一个示例：

http://i.imgur.com/4ywn17m.png

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

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

如何让循环为每位员工创建一个新行？

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

复制粘贴VBA循环

2 个答案: