Question

我试图找到一种解决方法，因为转置将不适合我的数据大小，这给了我一个错误。我要在循环结束之前（在下一步之前）添加什么，以将数据粘贴到新工作表上？如果输出100,000行，这会减慢宏的速度吗

查看代码后，我意识到，如果将范围设置为一定的数字，它将起作用，并且在此之后+1行会出错。原来移调是怪。

  For Q = 1 To Data + 1

                n = n + 1

                ReDim Preserve var(1 To 3, 1 To n)
                var(1, n) = 

                For R = 2 To 6
                    var(r, n) = 
                Next R
                var(1, n) = 
                var(2, n) = 
            Next Q

Next_Loop:
        Next P

        With this workbook.sheet1
            If Q>= 2 Then
               .Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(var)
            End If

结果应该不是在最后粘贴所有数据，而是在每次迭代后粘贴数据（除非它减慢了宏的速度）。下一次迭代将在前一行数据下方。等

感谢您的见识

Answer 1

这是您尝试的选项。

Sub LongColumnToAFewColumns()
    Dim wsF As Worksheet, WST As Worksheet
    Dim rf As Range, rT As Range
    Dim R As Long, j As Integer

    ' initialize
    Set wsF = ActiveSheet
    Set WST = Sheets.Add
    WST.Name = "Results"

    j = 1

    For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
        wsF.Cells(R, 1).Resize(65536).Copy
        WST.Cells(j, 1).PasteSpecial xlPasteValues

WST.Cells(j, 1).PasteSpecial xlPasteValues

        j = j + 1
    Next R

End Sub

如果要将一长列切成几行，请使用它。

Sub LongColumnToAFewRows()
    Dim wsF As Worksheet, WST As Worksheet
    Dim rf As Range, rT As Range
    Dim R As Long, j As Integer

    ' initialize
    Set wsF = ActiveSheet
    Set WST = Sheets.Add
    WST.Name = "Results2"

    j = 1

    For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step Columns.Count
        wsF.Cells(R, 1).Resize(Columns.Count).Copy
        WST.Cells(j, 1).PasteSpecial xlPasteValues, Transpose:=True
        j = j + 1
    Next R

End Sub

还有一个需要考虑。

Sub testing()
 Dim wsSource As Worksheet
 Dim wsDest As Worksheet
 Dim ptrSource As Long
 Dim ptrDest As Long
 Dim colDest As Long

    Set wsDest = Sheets.Add
    wsDest.Name = "Results"
    Set wsSource = Worksheets("Sheet1")

    colDest = 1
    ptrSource = 1
    ptrDest = 1
    Do While Len(wsSource.Cells(ptrSource, 1)) > 0
        wsDest.Cells(ptrDest, colDest) = wsSource.Cells(ptrSource, 1)
            If colDest = Columns.Count Then
                colDest = 0
                ptrDest = ptrDest + 1
            End If
        ptrSource = ptrSource + 1
        colDest = colDest + 1
    Loop
    Set wsDest = Nothing
    Set wsSource = Nothing

End Sub

移调功能的限制

1 个答案: