Combine Non-Consecutive Columnar Data to Single Columns

Question

I want to copy the values from Cols B, C, D to Col J while maintaining the values' row positions.
I want to copy the values from Cols E, F, G to Col K while maintaining row positions.

Desired results in Cols J & K. The colors are only to clarify my objective.

The number of rows will fluctuate weekly between 30 and 80 rows with new values.
Sometimes there will be gaps in the data as in Row 34...Col C Row 34 is blank. That has to be reflected in Col J. I border outlined those cells to demonstrate that there be data holes. I don't need to format borders if cells are blank.

I would like to use Col A as my Row Count because Col A will always determine how many rows will contain values for the next 6 Cols. Stated another way, the last values of the sheet will always be in the same row as the last value in Col A but they might not be in Cols C & F next week. There will always be a value in Col A if there are values in any of Cols B through G.

I tried creating individual declared ranges for each of Cols B, C, D, E, F, G, J & K but the copy function is not keeping the data in their original rows.

I tried creating declared ranges combining Cols A, B, C and Cols E, F, G but then my copy function is not amalgamating the data into 2 distinct columns.

Answer 1

ToCol in VBA

Excel

• The following formulas are adjusted to the screenshot below.

• In Excel you could do something like this:

  =TOCOL(B2:D11,1) 
  

  which excludes empty cells.

• To be on the safe side and exclude all blank cells you could use one of these:

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

• If you don't have Microsoft 365, you could use the VBA function below like this:

  =RangeToCol(B2:D11,1)
  

The Screenshot

• The range of interest in the following screenshot is B2:D11.
• It is important to understand that the white cells are blank but not empty. You may encounter such cells most notably when they contain a formula evaluating to ="" but also when copying data from a range that has such cells and pasting values.
• Excel's TOCOL doesn't consider them blank or as I would put it, with the 2nd parameter set to 1, it excludes only empty cells (which are a part of blank cells). Look at column G in the screenshot (ignore=1).
• Similarly, ISBLANK actually returns TRUE only for empty cells, as does COUNTA count all non-empty cells.
• On the other hand, COUNTBLANK 'understands' what a blank cell is.
• Study the bottom-left part of the screenshot to better understand what's that all about.

VBA

The Calling Procedure

• This procedure is adjusted to OP's screenshot.

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

The Main Function

• The same function but for rows, RangeToRow, can be found 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

The Helper 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