Question

我想使用Excel VBA宏动态连接数据，并且不知道如何处理不同行数和多列的数据传播。

以下是样本数据和所需输出的图像... _{（点击放大）。} screenshot

假设：

输出中所需的每个新行都从带有序列号的示例数据开始。但是在示例数据中，每个输出数据的行数会有所不同，如您所见的图像中，第一个输出行分布在样本数据中的3行，类似地，第二个和第三个输出行分布在5行和4行中在样本数据中。
columns A, B, C, D的输出应为column M
columns E, F的输出应为column N
columns G, H的输出应为column O
columns I, J, K的输出应为column P

我需要动态VBA代码，提示：

输出列数
输出列以column__
输入每列输出的列范围。

这是我编写的代码，用于连接范围与中间的空单元格，其中输入范围和输出单元格是手动选择的。

Sub Concatenate()
'Creates a basic CONCATENATE formula with no options
Call Concatenate_Formula(True, True)
End Sub

Sub Concatenate_Formula(bConcat As Boolean, bOptions As Boolean)

Dim rSelected As Range
Dim c As Range
Dim sArgs As String
Dim bCol As Boolean
Dim bRow As Boolean
Dim sArgSep As String
Dim sSeparator As String
Dim rOutput As Range
Dim vbAnswer As VbMsgBoxResult
Dim lTrim As Long
Dim sTitle As String

'Set variables
Set rOutput = ActiveCell
bCol = False
bRow = False
sSeparator = ""
sTitle = IIf(bConcat, "CONCATENATE", "Ampersand")

'Prompt user to select cells for formula
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
                "Select cells to create formula", _
                Title:=sTitle & " Creator", Type:=8)
On Error GoTo 0
'Only run if cells were selected and cancel button was not pressed
If Not rSelected Is Nothing Then

    'Set argument separator for concatenate or ampersand formula
    sArgSep = IIf(bConcat, ",", "&")

    'Prompt user for absolute ref and separator options
  If bOptions Then
        sSeparator = " "
    End If

    'Create string of cell references
    For Each c In rSelected.SpecialCells(xlCellTypeConstants)
        sArgs = sArgs & c.Address(bRow, bCol) & sArgSep
        If sSeparator <> "" Then
            sArgs = sArgs & Chr(34) & sSeparator & Chr(34) & sArgSep
        End If
    Next

    'Trim extra argument separator and separator characters
    lTrim = IIf(sSeparator <> "", 4 + Len(sSeparator), 1)
    sArgs = Left(sArgs, Len(sArgs) - lTrim)

    'Create formula
    'Warning - you cannot undo this input
    'If undo is needed you could copy the formula string
    'to the clipboard, then paste into the activecell using Ctrl+V
    If bConcat Then
        rOutput.Formula = "=CONCATENATE(" & sArgs & ")"
    Else
        rOutput.Formula = "=" & sArgs
    End If
    Selection.Copy
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
ActiveSheet.paste
Application.CutCopyMode = False
 rSelected = ""
End If
End Sub

如何修改此代码以跨越多列，多行和可变行数，如图所示？

Answer 1

考虑到数据的布局与图像中显示的完全相同，请试一试......

Sub ConcatenateData()
Dim lr As Long, cnt As Long, n As Long, dlr As Long
Dim Rng As Range, cell As Range, ConcatRng As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim str1 As String, str2 As String, str3 As String, str4 As String
Application.ScreenUpdating = False

lr = ActiveSheet.UsedRange.Rows.Count
Columns("M:P").ClearContents
Columns(1).Insert
With Range("A1:A" & lr)
    .Formula = "=IF(ISNUMBER(LEFT(B1,1)+0),1,NA())"
    .SpecialCells(xlCellTypeFormulas, 16).ClearContents
    .Value = .Value
End With
n = Range("A1:A" & lr).SpecialCells(xlCellTypeConstants, 1).Areas.Count
For Each Rng In Range("A1:A" & lr).SpecialCells(xlCellTypeConstants, 1).Areas
    cnt = cnt + 1
    If cnt <> n Then
        Set ConcatRng = Range(Rng, Rng.End(xlDown).Offset(-1))
        Set rng1 = ConcatRng.Offset(, 1).Resize(ConcatRng.Cells.Count, 4)
        Set rng2 = ConcatRng.Offset(, 5).Resize(ConcatRng.Cells.Count, 2)
        Set rng3 = ConcatRng.Offset(, 7).Resize(ConcatRng.Cells.Count, 2)
        Set rng4 = ConcatRng.Offset(, 9).Resize(ConcatRng.Cells.Count, 3)
    Else
        Set ConcatRng = Range(Rng, Range("A" & lr))
        Set rng1 = ConcatRng.Offset(, 1).Resize(ConcatRng.Cells.Count, 4)
        Set rng2 = ConcatRng.Offset(, 5).Resize(ConcatRng.Cells.Count, 2)
        Set rng3 = ConcatRng.Offset(, 7).Resize(ConcatRng.Cells.Count, 2)
        Set rng4 = ConcatRng.Offset(, 9).Resize(ConcatRng.Cells.Count, 3)
    End If

    For Each cell In rng1.SpecialCells(xlCellTypeConstants, 2)
        str1 = str1 & " " & cell.Value
    Next cell

    For Each cell In rng2.SpecialCells(xlCellTypeConstants, 1)
        str2 = str2 & " " & cell.Value
    Next cell

    For Each cell In rng3.SpecialCells(xlCellTypeConstants, 2)
        str3 = str3 & " " & cell.Value
    Next cell

    For Each cell In rng4.SpecialCells(xlCellTypeConstants, 2)
        str4 = str4 & " " & cell.Value
    Next cell
    If Range("N1").Value = "" Then
        dlr = 1
    Else
        dlr = Range("N" & Rows.Count).End(3)(2).Row
    End If
    Range("N" & dlr).Value = str1
    Range("O" & dlr).Value = str2
    Range("P" & dlr).Value = str3
    Range("Q" & dlr).Value = str4
    str1 = ""
    str2 = ""
    str3 = ""
    str4 = ""
Next Rng
Columns(1).Delete
Columns("M:P").AutoFit
Application.ScreenUpdating = True
End Sub

Excel VBA - 如何在多个动态行数和多列中连接数据

1 个答案: