Question

我正在寻找创建一个宏，该宏将允许我复制和粘贴一列中的数据，然后以正确的顺序将数据转置到两列中

我在手动执行过程时记录了一个宏

    Range("G3").Select
    Application.CutCopyMode = False
    Selection.Copy

    Range("G2:G7").Select          '   (The column range I want to copy)
    Application.CutCopyMode = False
    Selection.Copy

    Range("I1").Select                '    (Row where the range of G2:G7) is now transposed)
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    Range("H2:H7").Select          '   (The second column range I want to copy)
    Application.CutCopyMode = False
    Selection.Copy

    Range("I2").Select                '   (Second Row where the range of H2:H7) is now transposed)
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    Range("H8:H13").Select        '   (The third column range I want to copy)
    Application.CutCopyMode = FalseSelection.Copy

    Range("I3").Select' ( Third Row where the range of H8:H13) is now transposed)
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

问题是该代码最多只能处理一定数量的行（例如，直到H13），但是如果我要重复此过程，则直到H600行（H600的范围： H605）并粘贴到I31（例如，无需复制并粘贴此代码数百次），有什么办法可以做到这一点？

这就是我的示例

Column H
Star
Greenwood
Titon
Humford

已转换为

Column I      |    Column J**  
Star          |    Greenwood
titon         |    Humford

Answer 1

这是“复制/粘贴”的替代方法-使用变量数组。对于大型数据集，这将更快。

Sub Demo()
    Dim rng As Range
    Dim Src As Variant
    Dim Dst As Variant
    Dim GroupSize As Long
    Dim Groups As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim iDst As Long
    Dim SrcStartRow As Long
    Dim SrcColumn As Long
    Dim DstStartRow As Long
    Dim DstColumn As Long

    ' Set up Parameters
    GroupSize = 2
    SrcStartRow = 2
    SrcColumn = 8 'H
    DstStartRow = 1
    DstColumn = 9 'I

    With ActiveSheet 'or specify a specific sheet
        ' Get Reference to source data
        Set rng = .Range(.Cells(SrcStartRow, SrcColumn), .Cells(.Rows.Count, SrcColumn).End(xlUp))
        ' Account for possibility there is uneven amount of data
        Groups = Application.RoundUp(rng.Rows.Count / GroupSize, 0)
        If rng.Rows.Count <> Groups * GroupSize Then
            Set rng = rng.Resize(Groups * GroupSize, 1)
        End If


        'Copy data to Variant Array
        Src = rng.Value2

        'Size the Destination Array
        ReDim Dst(1 To UBound(Src, 1) / GroupSize, 1 To GroupSize)

        'Loop the Source data and split into Destination Array
        iDst = 0
        For iRow = 1 To UBound(Src, 1) Step GroupSize
            iDst = iDst + 1
            For iCol = 1 To GroupSize
                Dst(iDst, iCol) = Src(iRow + iCol - 1, 1)
            Next
        Next

        ' Move result to sheet
        .Cells(DstStartRow, DstColumn).Resize(UBound(Dst, 1), UBound(Dst, 2)).Value = Dst
    End With
End Sub

Answer 2

之前

好吧，您并不是真的要换位，但是我会使用这种方法。我从2开始，将第一个留在原处，然后基本上将第二个移到最前面，然后删除所有空白。

Sub MakeTwoColumns()

    Dim x As Long

    For x = 2 To 500 Step 2
        Cells(x, 6) = Cells(x, 5)
        Cells(x, 5).ClearContents
    Next x

    Columns(5).SpecialCells(xlCellTypeBlanks).Delete
    Columns(6).SpecialCells(xlCellTypeBlanks).Delete
End Sub

之后

用于从列到行复制和粘贴（转置）数据的宏-可伸缩

2 个答案: