VBA在循环中组合列堆栈答案

【问题标题】：VBA Combine columns stack in the loopVBA在循环中组合列堆栈
【发布时间】：2020-03-07 15:13:05
【问题描述】：

我在循环中遇到堆叠问题宏应将所有列（可更改的行数）合并为一列。

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

结束子

【问题讨论】：

标签： vba multiple-columns

【解决方案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

【讨论】：

【解决方案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

代码仍然需要一些改进，因为它可能会遍历所有列，尤其是在没有数据的情况下。

【讨论】：

【解决方案3】：

这假设您在所有列的第二行都有数据，以正确识别最后一列。

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

【讨论】：

【解决方案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

如果需要更改，请告诉我。

【讨论】：