VBA объединить столбцы стека в цикле

Question

У меня проблема со стеком в цикле. Макрос должен объединить все столбцы (изменяемое количество строк) в один столбец.

Sub CombineColumns()
Dim xRng As Range
Dim i As Integer
Dim xLastRow As Integer
On Error Resume Next
Set xRng = Application.Range("A1", Range("A1").End(xlDown).End(xlToRight))
xLastRow = xRng.Columns(1).Rows.Count + 1

For i = 2 To xRng.Columns.Count
    Range(xRng.Cells(1, i), xRng.Cells(xRng.Columns(i).Rows.Count, i)).Cut
    ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
    xLastRow = xLastRow + xRng.Columns(i).Rows.Count
Next

End Sub

Answer 1

Использование массива просто и быстро.

Sub test()
    Dim Ws As Worksheet, toWS As Worksheet
    Dim vDB, vR()
    Dim i As Long, j As Integer, n As Long
    Set Ws = ActiveSheet
    vDB = Ws.UsedRange

    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For i = 1 To r
        For j = 1 To c
            n = n + 1
            ReDim Preserve vR(1 To n)
            vR(n) = vDB(i, j)
        Next j
    Next i

    Set toWS = Sheets.Add ' set toWs = Sheets(2)  ~~> set your sheet
    With toWS
        .Cells.Clear
        .Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Answer 2

Если я правильно понял, ты хочешь сделать что-нибудь. вот так

Option Explicit

Sub CombineColumns()
    Dim xRng As Range
    Dim i As Long
    Dim xLastRow As Long
    'On Error Resume Next
    Set xRng = Application.Range("A1", Range("A1").End(xlToRight))
    xLastRow = lastRow(1) + 1

    For i = 2 To xRng.Columns.Count
        Range(xRng.Cells(1, i), xRng.Cells(lastRow(i), i)).Cut
        ActiveSheet.Paste Destination:=xRng.Cells(xLastRow, 1)
        xLastRow = lastRow(1) + 1
    Next
End Sub

Function lastRow(col As Long, Optional wks As Worksheet) As Long

    If wks Is Nothing Then
        Set wks = ActiveSheet
    End If

    lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row


End Function

Код все еще нуждается в некотором улучшении, так как он может составлять l oop по всем столбцам, особенно если данных нет.

Answer 3

Предполагается, что для всех ваших столбцов у вас есть данные во 2-й строке, чтобы правильно идентифицировать последний столбец.

Option Explicit

Public Sub CombineColumns()
    Dim LastColumn As Long, LastRow As Long, LastRowA As Long, i As Long, RngAddress As String

    With ActiveSheet
        ' This assumes you have data on row 2 on all columns
        LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column

        For i = 2 To LastColumn
            ' Get the last row of Col A on each iteration
            LastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            ' Get last row of the Col we're checking
            LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
            ' Get the used range address of the current Col
            RngAddress = .Range(.Cells(1, i), Cells(LastRow, i)).Address
            ' Check if we have blank cells among the rows of the current Col
            .Range(.Cells(1, i), Cells(LastRow, i)).Value2 = Evaluate("IF(NOT(ISBLANK(" & RngAddress & "))," & RngAddress & ")")
            ' Compress data (if there's no empty cells in the current Col the below line will give error, that's the role of err handling)
            On Error Resume Next
            .Range(.Cells(1, i), Cells(LastRow, i)).SpecialCells(xlCellTypeConstants, 4).Delete xlShiftUp
            On Error GoTo 0
            ' Update the last row in case we compressed data
            LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
            ' Paste data in Col A
            .Range(.Cells(1, i), Cells(LastRow, i)).Cut Destination:=.Range("A" & LastRowA)
        Next i
        Application.CutCopyMode = False
    End With
End Sub

Answer 4

Возможно, это может быть удобным решением для вас:

Sub CombineColumns()
Dim LastRow As Long

LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Range("A2:A" & LastRow).Formula = "=B2 & C2 & D2 & E2 & F2 & G2 & H2" 'Insert here the columns you need to be combined

End Sub

Дайте мне знать, если изменения необходимы.