Question

我将这些列放在一个excel表中：

1,2,3,4,5,6,7,8,9,10...
1a,2a,3a,4a,5a,6a,7a,8a,9a,10a...
...

我希望将这些列复制到另一个excel文件，并将每第5列拆分为另一行

1,2,3,4,5
6,7,8,9,10
1a,2a,3a,4a,5a
6a,7a,8a,9a,10a

Answer 1

我假设您要分离的数据仅位于第一行。如果是这样的话，以下内容应该会有所帮助：

 Sub columnsInRows()

        Dim rngData As Range
        Dim intDelimiter As Integer
        Dim arrRows As Variant
        Dim cell As Range
        Dim counter As Integer
        Dim row As Integer


        row = 1
        intDelimiter = 5

        Worksheets("Table1").Activate

        Set rngData = Worksheets("Table1").UsedRange

        ReDim arrRows(rngData.Cells.Count - 1)

        For Each cell In rngData.Rows.Cells
            arrRows(counter) = cell.Value
            counter = counter + 1
        Next

        Worksheets("Table2").Activate

        For counter = 0 To UBound(arrRows)
            Cells(row, counter Mod intDelimiter + 1).Value = arrRows(counter)
                If (counter + 1) Mod intDelimiter = 0 Then
                    row = row + 1
                End If
        Next
        Worksheets("Table2").UsedRange.NumberFormat = "#,##0.00"

    End Sub

Answer 2

这将全部完成：

Sub evyfifth()
    Dim ws As Worksheet
    Dim ows as Worksheet
    Dim rngarr() As Variant
    Dim oarr() As Variant
    Dim lastclm As Long
    Dim lastrw As Long
    Dim i&, j&, x&, y&, clms&

    clms = 5

    Set ws = Sheets("Sheet16") 'Change to the sheet of data
    Set ows = Sheets("Sheet17") ' Change to output sheet

    With ws
        lastclm = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        lastrw = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        rngarr = .Range(.Cells(1, 1), .Cells(lastrw, lastclm)).Value
        ReDim oarr(1 To Application.RoundUp(lastrw * (lastclm / clms), 0), 1 To clms)
        x = 1
        For i = 1 To UBound(rngarr, 1)
            y = 1
            For j = 1 To UBound(rngarr, 2)
                If y < clms Then
                    oarr(x, y) = rngarr(i, j)
                    y = y + 1
                Else
                    oarr(x, y) = rngarr(i, j)
                    y = 1
                    x = x + 1
                End If
            Next j
        Next i

    End With
    ows.Range("A1").Resize(UBound(oarr, 1), clms).Value = oarr



End Sub

非常快。

将每5列拆分为另一行

2 个答案: