将非连续的列式数据合并为单列

Question

我想将值从 B、C、D 列复制到 J 列，同时保留值的行位置。
我想将值从 E、F、G 列复制到 K 列，同时保持行位置。

Cols J & K 中的预期结果。颜色只是为了阐明我的目标。

行数每周将在 30 到 80 行之间波动并出现新值。
有时数据中会存在间隙，如第 34 行...C 列第 34 行为空白。这必须反映在 J 上校中。我用边框勾勒出这些单元格，以证明存在数据漏洞。如果单元格为空白，我不需要设置边框格式。

我喜欢使用 Col A 作为我的行计数，因为 Col A 将始终确定有多少行将包含接下来 6 列的值。换句话说，工作表的最后一个值将始终与 A 列中的最后一个值位于同一行，但下周它们可能不在 C 和 F 列中。如果 B 列到 G 列中的任何一个都有值，则 A 列中始终会有一个值。

我尝试为每个列 B、C、D、E、F、G、J 和 K 创建单独的声明范围，但复制功能不会将数据保留在原始行中。

我尝试创建组合列 A、B、C 和列 E、F、G 的声明范围，但我的复制函数并未将数据合并为 2 个不同的列。

Answer 1

VBA 中的 ToCol

Excel

• 以下公式调整为如下截图。

• 在 Excel 中，您可以执行以下操作：
  =TOCOL(B2:D11,1) 排除空单元格。

• 为了安全起见并排除所有空白单元格，您可以使用以下之一：

  =LET(c,TOCOL(B2:D11),FILTER(c,c<>""))
  =TOCOL(IF(B2:D11<>"",B2:D11,NA()),3)

• 如果您没有 Microsoft 365，您可以使用下面的 VBA 函数，如下所示：
  =RangeToCol(B2:D11,1)

截图

下面截图中感兴趣的范围是
• B2:D11

  。

重要的是要了解白细胞是空白但不是空的。您可能会遇到此类单元格，尤其是当它们包含计算结果为
• =""

   的公式时，以及从具有此类单元格的范围复制数据并粘贴值时。

Excel 的
• TOCOL

   不认为它们是空白的，或者正如我所说，当第二个参数设置为 1 时，它仅排除空单元格（它们是空白单元格的一部分）。查看屏幕截图中的第 

  G

   列 (

  ignore=1

  )。

类似地，
• ISBLANK

  实际上仅针对空单元格返回

  TRUE

  ，

  COUNTA

  也会对所有非空单元格进行计数。

另一方面，
• COUNTBLANK

  “理解”空白单元格是什么。

研究屏幕截图的左下部分，以更好地了解其含义。

VBA

调用流程

此流程已根据OP截图进行调整。

Sub CopyToSingleColumns()
 
    Const SRC_SHEET As String = "Sheet1"
    Const SRC_FIRST_CELL As String = "A2"
    Dim sCols(): sCols = VBA.Array("B:D", "E:G")
    Const DST_SHEET As String = "Sheet1"
    Dim dfCells(): dfCells = VBA.Array("J2", "K2")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    Dim srg As Range
    With sws.Range(SRC_FIRST_CELL)
        Set srg = sws.Range( _
            .Cells, sws.Cells(sws.Rows.Count, .Column).End(xlUp))
    End With
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    
    Dim sData(), n As Long
    
    For n = 0 To UBound(sCols)
        sData = RangeToCol(srg.EntireRow.Columns(sCols(n)), 1)
        dws.Range(dfCells(n)).Resize(UBound(sData)).Value = sData
    Next n
    
    MsgBox "Values copied to single columns.", vbInformation
    
End Sub

主要功能

相同的功能，但对于行，
• RangeToRow

  ，可以找到

  here。

Function RangeToCol( _
    ByVal rg As Range, _
    Optional ByVal Ignore As Long = 0, _
    Optional ByVal ScanByColumn As Boolean = False) _
As Variant

    Dim srCount As Long: srCount = rg.Rows.Count
    Dim scCount As Long: scCount = rg.Columns.Count
    Dim drCount As Long: drCount = srCount * scCount
    
    Dim sData()
    
    If drCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = rg.Value
    Else
        sData = rg.Value
    End If
    
    Dim dArr(): ReDim dArr(1 To drCount)
    
    Dim sVal, sr As Long, sc As Long, dr As Long
    
    If ScanByColumn Then
        For sc = 1 To scCount
            For sr = 1 To srCount
                If IsErrorBlankTestPassed(sData(sr, sc), Ignore) Then
                    dr = dr + 1
                    dArr(dr) = sData(sr, sc)
                End If
            Next sr
        Next sc
    Else
        For sr = 1 To srCount
            For sc = 1 To scCount
                If IsErrorBlankTestPassed(sData(sr, sc), Ignore) Then
                    dr = dr + 1
                    dArr(dr) = sData(sr, sc)
                End If
            Next sc
        Next sr
    End If
    
    If drCount = 0 Then Exit Function ' only blanks and/or errors
    
    Dim dData(): ReDim dData(1 To dr, 1 To 1)
    
    For dr = 1 To dr
        dData(dr, 1) = dArr(dr)
    Next dr
    
    RangeToCol = dData

End Function

辅助功能

Function IsErrorBlankTestPassed( _
    ByVal Value As Variant, _
    ByVal Ignore As Long) _
As Boolean
    Dim IsAddable As Boolean
    Select Case Ignore
        Case 0: IsAddable = True ' nothing
        Case 1: If Len(CStr(Value)) > 0 Then IsAddable = True ' blanks
        Case 2: If Not IsError(Value) Then IsAddable = True ' errors
        Case 3:
            If Not IsError(Value) Then ' blanks and errors
                If Len(CStr(Value)) > 0 Then IsAddable = True
            End If
    End Select
    IsErrorBlankTestPassed = IsAddable
End Function

Answer 2

下面的代码假设所有表示为空白的单元格实际上都是空白的（即

没有填充了被认为不相关的数据）

Sub consolidate()
    Dim colJ, colK, i As Long, lastRow As Long
    With ActiveSheet   'change as required
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        colJ = .Cells(2, 2).Resize(lastRow - 1, 3).Value2
        colK = .Cells(2, 5).Resize(lastRow - 1, 3).Value2
        For i = 1 To lastRow - 1
            colJ(i, 1) = colJ(i, 1) + colJ(i, 2) + colJ(i, 3)
            If colJ(i, 1) = 0 Then colJ(i, 1) = vbNullString
            colK(i, 1) = colK(i, 1) + colK(i, 2) + colK(i, 3)
            If colK(i, 1) = 0 Then colK(i, 1) = vbNullString
        Next i
        .Cells(2, 10).Resize(i - 1, 1).Value2 = colJ
        .Cells(2, 11).Resize(i - 1, 1).Value2 = colK
    End With
End Sub

Answer 3

The non-elegant solution.

'Declare Destination Ranges of Groups A, B and C for Session 1
Dim DestRngOne As Range

'Declare Destination Ranges of Groups A, B and C for Session 2
Dim DestRngTwo As Range

'Set Source Ranges for Session 1
Set SrcRngOneA = Range("F2:F80")
Set SrcRngOneB = Range("G2:G80")
Set SrcRngOneC = Range("H2:H80")

'Set Source Ranges for Session 2
Set SrcRngTwoA = Range("I2:I80")
Set SrcRngTwoB = Range("J2:J80")
Set SrcRngTwoC = Range("K2:K80")

'Set Destination Range for Session 1
Set DestRngOne = Range("R2:R80")

'Set Destinat
ion Range for Q Session 1
Set DestRngTwo = Range("U2:U80")

'Paste Ranges of Cells
SrcRngOneA.Copy
DestRngOne.PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
SrcRngOneB.Copy
DestRngOne.PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
SrcRngOneC.Copy
DestRngOne.PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
SrcRngTwoA.Copy
DestRngTwo.PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
SrcRngTwoB.Copy
DestRngTwo.PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
SrcRngTwoC.Copy
DestRngTwo.PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True

Application.CutCopyMode = False

End Sub