Как складывать столбцы в Excel

Question

У меня есть электронная таблица данных в текущем формате:

A1, A2, A3,B1,B2,B3,C1,C2,C3

Я пытаюсь собрать данные таким образом, чтобы они соответствовали следующему формату:

A1, A2, A3,
B1, B2, B3
C1, C2, C3

Этопоэтому я могу импортировать в какое-то программное обеспечение в правильном формате.

Я нашел следующий код онлайн, который действительно суммирует данные, однако он суммирует каждый столбец, тогда как мне нужно, чтобы он складывал каждый третий столбец и задавался вопросом, есть лиможно просто изменить этот макрос, чтобы сделать это?

Заранее спасибо.

Option Explicit


Sub Stack_cols()


On Error GoTo Stack_cols_Error

Dim lNoofRows As Long, lNoofCols As Long
Dim lLoopCounter As Long, lCountRows As Long
Dim sNewShtName As String
Dim shtOrg As Worksheet, shtNew As Worksheet

'Turn off the screen update to make macro run faster
Application.ScreenUpdating = False
'Ask for a new sheet name, if not provided use newsht
sNewShtName = InputBox("Enter the new worksheet name", "Enter name", "newsht")
'Set a sheet variable for the sheet where the data resides
Set shtOrg = ActiveSheet
'Add a new worksheet, rename it and set it to a variable
If Not SheetExists(sNewShtName) Then
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
    Set shtNew = Worksheets(sNewShtName)
Else
    MsgBox "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
    Exit Sub
End If

With shtOrg
    'Get the last column number
    'Replace .Range("IV1") with .Range("XFD1") for Excel 2007
    lNoofCols = .Range("IV1").End(xlToLeft).Column
    'Start a loop to copy and paste data from the first column to the last column
    For lLoopCounter = 1 To lNoofCols
    'Count the number of rows in the looping column
        'Replace .Cells(65536, lLoopCounter) with .Cells(1048576, lLoopCounter) for Excel 2007
        lNoofRows = .Cells(65536, lLoopCounter).End(xlUp).Row
        .Range(.Cells(1, lLoopCounter), .Cells(lNoofRows, lLoopCounter)).Copy Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + lNoofRows, 1))
        'count the number of rows in the new worksheet
        lCountRows = lCountRows + lNoofRows
    Next lLoopCounter
End With

On Error GoTo 0
SmoothExit_Stack_cols:
        Application.ScreenUpdating = True
        Exit Sub

Stack_cols_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub:Stack_cols"
    Resume SmoothExit_Stack_cols
End Sub
'Check if a worksheet exists or not
Public Function SheetExists(sShtName As String) As Boolean
    On Error Resume Next


Dim wsSheet As Worksheet, bResult As Boolean
bResult = False
Set wsSheet = Sheets(sShtName)

On Error GoTo 0
If Not wsSheet Is Nothing Then
    bResult = True
End If
SheetExists = bResult
End Function

Answer 1

Попробуйте следующее:

Sub Test()

Dim lc As Long, x As Long, y As Long
Dim arr As Variant

With Sheet1 'Change accordingly
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr = .Cells(1, 1).Resize(1, lc)
    .Cells(1, 1).Resize(1, lc).Clear
    y = 1
    For x = 1 To lc Step 3
        .Cells(y, 1).Resize(1, 3).Value = Array(arr(1, x), arr(1, x + 1), arr(1, x + 2))
        y = y + 1
    Next x
End With

End Sub

Answer 2

Мне нравится быть простым, вот еще один пример ...

Dim x As Long, y As Long, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet3") 'change sheet as needed

x = 1
y = 2

    With ws
        For x = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 3
            .Cells(1, x).Resize(, 3).Copy Destination:=ws.Cells(y, 1)
            y = y + 1
        Next x

        .Cells(1, 4).Resize(, .Cells(1, .Columns.Count).End(xlToLeft).Column).Clear
    End With

Answer 3

Код, который вы разместили, кажется слишком сложным для того, чего вы пытаетесь достичь, попробуйте это:

Sub stackColumns()

Dim lngRow As Long, lngCol As Long, i As Long
lngRow = 1
lngCol = 0

For i = 1 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(lngRow, lngCol + 1).Value = ActiveSheet.Cells(1, i).Value
    If lngRow > 1 Then ActiveSheet.Cells(1, i).Clear
    lngCol = (lngCol + 1) Mod 3
    If lngCol = 0 Then lngRow = lngRow + 1
Next i

End Sub

Это предполагает, что ваши данные начинаются в ячейке A1.