Question

我试图弄清楚如何根据动态范围开始自动填充。对于“起始表”中的每一列＆＃39;我需要将它们堆叠在一起。我目前的代码是从＆＃39; LastRow＆＃39;不这样做。我希望LastRow会给我一个动态范围自动填充，但我得到错误，＆＃39;对象变量或未设置块变量＆＃39;

如何更改我的代码，以便＆＃39; 2移动＆＃39;自动填充表格的新大小，而不知道它从哪里开始？然后重复“03ove”的过程。和＆＃39; 4Move＆＃39;

Sub shiftingColumns()

Dim sht As Worksheet
Dim LastRow As Range

Set sht = ActiveSheet

Set copyRange = Sheets("Sheet1").Range(Range("A2:B2"), Range("A2:B2").End(xlDown))
'Insert column & add header
Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").Value = "Category"
'Move D1 Value to C2
Range("D1").Cut Destination:=Range("C2")
'Autofill C2 value to current table size
Range("C2").AutoFill Destination:=Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
'Copy copyRange below itself 
copyRange.Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1)
'Move E1 below autofilled ranged
Range("E1").Cut Destination:=Range("C" & Rows.Count).End(xlUp).Offset(1)
'LastRow = sht.Cells(sht.Rows.Count, "C").End(xlUp).Row
'LastRow.AutoFill Destination:=Range(LastRow & Range("A" & Rows.Count).End(xlUp).Row)
End Sub

这是起始表

这是所需的表格

Answer 1

为了通过搜索引擎找到这些人的好处，你要做的事情不是自动填充。

这应该适合你，一个循环。

Sub test()

    workingSheet = ActiveSheet.Name
    newSheet = "New Sheet"

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(newSheet).Delete
    Application.DisplayAlerts = True
    Sheets.Add.Name = newSheet
    Cells(1, 1) = "ID"
    Cells(1, 2) = "Color"
    Cells(1, 3) = "Category"
    On Error GoTo 0

    Sheets(workingSheet).Activate
    'Get last column
    x = Cells(1, 3).End(xlToRight).Column
    y = Cells(1, 1).End(xlDown).Row

    'Loop for each column from 3 (column "C") and after
    For i = 3 To x

        With Sheets(newSheet)

            newRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            'Copy ID and Color
            Range(Cells(2, 1), Cells(y, 2)).Copy .Range(.Cells(newRow, 1), .Cells(newRow + y, 2))
            'Copy column header
            .Range(.Cells(newRow, 3), .Cells(newRow + (y - 2), 3)) = Cells(1, i)
            'Copy column values
            Range(Cells(2, i), Cells(y, i)).Copy .Range(.Cells(newRow, 4), .Cells(newRow + y, 4))
        End With

    Next

End Sub

如果您的要求有所不同，例如添加ID和Color等其他“固定”列，则必须更改单元格寻址等。

Answer 2

这两种方法将比Range.Copy和Range.Paste更快地转置数据。

PivotTableValues - 将Range.Value转储到数组数据中，然后使用转置值填充第二个数组结果。注意：在此上下文中转置只是意味着移动到不同的位置。

PivotTableValues2 - 使用Arraylists来实现OP的目标。虽然它很有效，但它有点是一个很好的答案。我只是想以深奥的理由尝试这种方法。

使用数组的数据透视表

Sub PivotTableValues()
    Const FIXED_COLUMN_COUNT As Long = 2
    Dim ArrayRowCount As Long, Count As Long, ColumnCount As Long, RowCount As Long, x As Long, y As Long, y2 As Long
    Dim data As Variant, results As Variant, v As Variant

    With ThisWorkbook.Worksheets("Sheet1")
        RowCount = .Range("A" & .Rows.Count).End(xlUp).Row
        ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
        data = Range(.Range("A" & .Rows.Count).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft)).Value

        ArrayRowCount = (ColumnCount - FIXED_COLUMN_COUNT) * (RowCount - 1) + 1

        ReDim results(1 To ArrayRowCount, 1 To FIXED_COLUMN_COUNT + 2)

        Count = 1
        For y = FIXED_COLUMN_COUNT + 1 To ColumnCount
            For x = 2 To RowCount
                Count = Count + 1
                results(Count, FIXED_COLUMN_COUNT + 1) = data(1, y)
                results(Count, FIXED_COLUMN_COUNT + 2) = data(x, y)
                For y2 = 1 To FIXED_COLUMN_COUNT
                    If Count = 2 Then
                        results(1, y2) = data(1, y2)
                        results(1, y2 + 1) = "Category"
                        results(1, y2 + 2) = "Value"
                    End If
                    results(Count, y2) = data(x, y2)
                Next
            Next
        Next

    End With

    With ThisWorkbook.Worksheets.Add
        .Range("A1").Resize(UBound(results), UBound(results, 2)).Value = results
        .Columns.AutoFit
    End With

End Sub

PivotTableValues2使用ArrayLists

Sub PivotTableValues2()
    Const FIXED_COLUMN_COUNT As Long = 2
    Dim ColumnCount As Long, RowCount As Long, x As Long, y As Long
    Dim valueList As Object, baseList As Object, results As Variant, v As Variant
    Set valueList = CreateObject("System.Collections.ArrayList")
    Set baseList = CreateObject("System.Collections.ArrayList")

    With ThisWorkbook.Worksheets("Sheet1")
        RowCount = .Range("A" & .Rows.Count).End(xlUp).Row
        ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column

        For x = 1 To RowCount
            baseList.Add Application.Transpose(Application.Transpose(Range(.Cells(x, 1), .Cells(x, FIXED_COLUMN_COUNT))))
        Next

        For y = FIXED_COLUMN_COUNT + 2 To ColumnCount
            baseList.AddRange baseList.getRange(1, RowCount - 1)
        Next

        For y = FIXED_COLUMN_COUNT + 1 To ColumnCount
            For x = 2 To RowCount
                valueList.Add Array(.Cells(1, y).Value, .Cells(x, y).Value)
            Next
        Next

    End With

    results = Application.Transpose(Application.Transpose(baseList.ToArray))

    With ThisWorkbook.Worksheets.Add
        .Range("A1").Resize(UBound(results), UBound(results, 2)).Value = results
        valueList.Insert 0, Array("Category", "Value")

        results = Application.Transpose(Application.Transpose(valueList.ToArray))
        .Cells(1, FIXED_COLUMN_COUNT + 1).Resize(UBound(results), UBound(results, 2)).Value = results
        .Columns.AutoFit
    End With

End Sub

自动填充基于动态行

2 个答案:

使用数组的数据透视表

PivotTableValues2使用ArrayLists