How select columns in a table based on index from array in VBA?

Question

I have a table ("horiz") with following values

and table ("data") that shows different values per column

I want to make a VBA code that will save table "data" as following.

Basically looking for a code, which can do it in the following way: 1)load "horiz" values as an array 2)load "data" as a range 3)delete all zero values from "horiz" array 4)save the "data" table with column indexes that follow the values from array "horiz"

I tried the following code, however, the saving part is not working properly and do not know how to delete zeros in 3) step (I read that something should be done with If condition and ReDim function)

Sub sample()

Dim DirArray As Variant
DirArray = Range("horiz").Value

Dim rng As Range
Set rng = Range("data")

Worksheets("Sheet1").Range("L1").Cells.Value = rng.Cells(, DirArray).Value

End Sub

user_9814069 · Answer

Copy 'Selected' Columns

Option Explicit

Sub copySelectedColumns()
    
    Dim srg As Range: Set srg = Range("horiz") ' Select Range
    Dim cCount As Long: cCount = Application.CountIf(srg, ">0") ' Columns Count
    Dim sData As Variant: sData = srg.Value ' Select Data (Array)

    Dim Data As Variant: Data = Range("data").Value ' Data
    
    Dim ColData As Variant: ReDim ColData(1 To cCount) ' Column Data (Array)

    Dim n As Long, c As Long

    For n = 1 To UBound(sData, 2)
        If sData(1, n) > 0 Then
            c = c + 1
            ColData(c) = sData(1, n)
        End If
    Next n
    
    Dim rCount As Long: rCount = UBound(Data, 1)
    Dim Result As Variant: ReDim Result(1 To rCount, 1 To cCount) ' Result

    Dim r As Long

    For r = 1 To rCount
        For c = 1 To cCount
            Result(r, c) = Data(r, ColData(c))
        Next c
    Next r
    
    Worksheets("Sheet1").Range("L1").Resize(rCount, cCount).Value = Result

End Sub

EDIT

The improvement is about not allowing impossible columns (greater than the number of columns in the Data Range (0 was previously included)) and clearing the contents of a previous result.
The small range study is about writing the addresses of the four ranges to the Immediate window (CTRL+G).

An Improvement feat. a Small Range Study

Sub copySelectedColumns()
    
    Debug.Print "***** The Ranges *****"
    
    Dim srg As Range: Set srg = Range("horiz") ' Select Range
    Debug.Print "Select Range: " & srg.Address(0, 0)
    Dim sData As Variant: sData = srg.Value ' Select Data (Array)
    Dim sCount As Long: sCount = UBound(sData, 2) ' Select Columns Count
    
    Dim drg As Range: Set drg = Range("data") ' Data Range
    Debug.Print "Data Range:   " & drg.Address(0, 0)
    Dim Data As Variant: Data = drg.Value ' Data
    Dim dCount As Long: dCount = UBound(Data, 2) ' Data Columns Count
    
    Dim ColData As Variant: ReDim ColData(1 To sCount) ' Column Data (Array)

    Dim n As Long, c As Long

    For n = 1 To sCount
        If sData(1, n) > 0 And sData(1, n) <= dCount Then
            c = c + 1
            ColData(c) = sData(1, n)
        End If
    Next n
    
    If c > 0 Then
        
        Dim cCount As Long: cCount = c
        Dim rCount As Long: rCount = UBound(Data, 1)
        Dim Result As Variant: ReDim Result(1 To rCount, 1 To cCount) ' Result
    
        Dim r As Long
    
        For r = 1 To rCount
            For c = 1 To cCount
                Result(r, c) = Data(r, ColData(c))
            Next c
        Next r
        
        With Worksheets("Sheet1").Range("L2")
            
            ' Clear contents of previous result.
            Dim crg As Range ' Clear Range
            Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1, sCount)
            Debug.Print "Clear Range:  " & crg.Address(0, 0)
            crg.ClearContents
            
            ' Write result.
            Dim rrg As Range: Set rrg = .Resize(rCount, cCount) ' Result Range
            Debug.Print "Result Range: " & rrg.Address(0, 0)
            rrg.Value = Result
        
        End With

    Else
        
        ' all values in Select Range are invalid
        ' (0 or greater than Data Columns Count (dCount))
        Debug.Print "The Select Range '" & srg.Address(0, 0) & "' contains " _
            & "only invalid data."
    
    End If
    
End Sub

user_9199828 · Answer

Try:

Sub cut_paste_delete()
Dim ArrayHeader As Variant
Dim ArrayData As Variant
Dim FinalArray As Variant
Dim i As Long
Dim ZZ As Long
Dim vColumn As Long


ArrayHeader = Range("horiz").Value
ArrayData = Range("data").Value

i = Application.WorksheetFunction.CountIf(Range("horiz"), "<>0") 'how many valid columns
ReDim FinalArray(1 To UBound(ArrayData), 1 To i) As Variant

For i = 1 To 5 Step 1
    If ArrayHeader(1, i) <> 0 Then
        vColumn = vColumn + 1
        For ZZ = 1 To UBound(ArrayData) Step 1
            FinalArray(ZZ, vColumn) = ArrayData(ZZ, i)
        Next ZZ
    End If
Next i

'paste final array somewhere, in my case in P1
Range(Cells(1, 16), Cells(1 + ZZ - 2, 16 + vColumn - 1)).Value = FinalArray

Erase ArrayHeader, ArrayData, FinalArray


End Sub

The output i get afcter executing code:

user_6600940 · Answer

Another approach could be

Sub CopyRg()
    Dim rgKeep As Range
    Dim rgData As Range
    Dim rgResult As Range
        
    Set rgKeep = Range("B2").CurrentRegion
    Set rgData = Range("D7").CurrentRegion
    
    Dim i As Long
    i = 1
    
    Dim sngColumn As Range
    For Each sngColumn In rgData.Columns
        
        If rgKeep.Columns(i).Value <> 0 Then
            If rgResult Is Nothing Then
                Set rgResult = sngColumn
            Else
                Set rgResult = Union(rgResult, sngColumn)
            End If
        End If
        i = i + 1
    Next sngColumn
    
    rgResult.Copy
    Range("B12").PasteSpecial

End Sub

with the following data (input and output)

The code does not transfer the data into arrays which could be slow for large datasets but on the other hands it only loops through the columns.

How select columns in a table based on index from array in VBA?

3 Answers

Copy 'Selected' Columns

EDIT