Question

我有一个包含61个数据字段的成员列表（垂直）。我需要将每个成员转移/转置到另一张表。

示例数据：

Name:
Last Name:
Address:
Membership Date:
Maiden Name:
...
61 items

我得到的文件为每个成员重复数据字段标题，因此文件宽2列，长50k

我想将列b复制到另一张表。

所以这就是我所拥有的，我不知道下一步该去哪里。

Sub CopyTranspose()
    Dim rng As Range
    Dim i As Long

    Set rng = ThisWorkbook.ActiveSheet.Range("B1:B51000")
    With rng

        ' Loop through all cells of the range
        For i = 1 To 51000 Step 1
            'Select member data fields
            Range("B2:B61").Select

            ' Copy and transpose
            Selection.Copy
            Sheets("Sheet1").Select
            Range("A2").Select
            Range("A2").Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
              False, Transpose:=True
        Next i
    End With
End Sub

我知道它不对，我知道我需要为每次迭代添加61并粘贴到最后一个空白行。我假设我为I-61 + x迭代次数添加了另一个变量。然后我在粘贴端执行某些操作以跳转到最后一个空单元格？

感谢您的帮助。

Answer 1

使用数组转置数据比使用复制/粘贴更快更快。鉴于您的数据集的大小，我认为快速解决方案更可取......

' Get last row in copy-from sheet
Dim lastRow as Long
lastRow = Sheets("DataSheet").Range("A" & Rows.Count).End(xlUp).Row
' Loop down that sheet, copying blocks of 61 rows
Dim i as Long
Dim dataArray as Variant
For i = 1 To lastRow Step 61
    ' Assign data to an array
    dataArray = Sheets("DataSheet").Range("B" & i & ":B" & i + 60)
    ' Stick the values of that transposed array into the summary sheet
    With Sheets("TransposedSheet")
        .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + 1).value = Application.Transpose(dataArray)
    End With
Next i

我提到了速度。为了比较，我实现了我的方法，acsql的复制/粘贴方法，以及设置了Application.ScreenUpdating = False的复制/粘贴方法。最后一个选项是加速宏的众所周知的方法。 B列中4000行仅一位数的结果：

数组方法：0.01171875 s
复制粘贴方法（屏幕更新为真）0.7890625 s
复制粘贴方法（屏幕更新错误）0.3671875 s

所以使用数组！

Answer 2

假设您希望将每个数据点作为列和列，并且这应该可行。每个人都有一个新行？

lRow = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To lRow Step 61

    iStart = i
    iEnd = i + 60

    Sheets("Data").Range("B" & iStart & ":B" & iEnd).Copy

    Sheets("Sheet1").Range("A" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Next i

Excel，尝试复制，转置X个单元格

2 个答案: