Load a Multidimensional array

[fredlo2010]

Hello guys,

I am trying to create a multidimensional array. I want to go through the headers of a specific range and if the values equal another one specified for them.

In the end I want to get the values in the array and copy them to another sheet.

I can do this with a range but I want to use an array because its faster.

This is the code I have so far.

Sub createList()

Dim arr() As Variant
Dim arrHeaders As Variant
Dim lRow As Long
Dim sh As Worksheet
Dim r As Range


' Headers I want to keep
lRow = Sheets("Orders").Range("C1").CurrentRegion.Rows.Count


arrHeaders = Array("Sales order", "Name", "Record", "Order type")
ReDim arr(1 To lRow, 1 To UBound(arrHeaders))
'Loop through the headers to pic the corrct ones


For i = 1 To Sheets("Orders").Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 0 To UBound(arrHeaders)
        If Cells(1, i).Value = arrHeaders(j) Then
            ' I need to figuere out this part.
            arr = Cells(1, i).Resize(UBound(arr, 1), 1).Value
        End If
    Next
Next


End Sub

Thanks

[SamT]

Written in VBAX Editor >> UnTested:

Sub createList() 
 'Save up to 4 columns, in Column order, to arr, if Column Header match value in WantedHeaders    
     
    WantedHeaders = Array("Sales order", "Name", "Record", "Order type") 
   ULimitWantedHeaders = UBound(WantedHeaders) 'Set once, use many times
     
    lRow = Sheets("Orders").Range("C1").CurrentRegion.Rows.Count 
     
     
    Redim arr(1 To lRow, 1 To ULimitWantedHeaders+1)
     arrIndex = 0
     
    For Col = 1 To LastUsedColumn of Sheets("Orders")
       For HeaderNum = 0 To ULimitWantedHeaders
           If Cells(1, Col).Value = WantedHeaders(HeaderNum) Then 
                arr(arrIndex) = Cells(1, Col).Resize(Lrow, 1).Value 
                ArrIndex = arrIndex + 1
            End If 
        Next 
    Next      
End Sub

For more speed, and to save the columns in the same order as Wanted Headers

'add
Dim ColHeaders as Variant

With Sheets("Orders")
Redim ColHeaders(1 to LastUsedColumn)
ColHeaders = Range(Cells(1,1), Cells(1, LastUsedColumn))

'Replace
  For HeaderNum = 0 To ULimitWantedHeaders
     For ColHeadersIndex = 0 To UBound(ColHeaders)
          If ColHeaders(ColHeadersIndex) = WantedHeaders(HeaderNum) Then 
                arr(HeaderNum) = Cells(1, ColHeadersIndex + 1).Resize(Lrow, 1).Value 
            End If 
        Next 
    Next

[Bob Phillips]

I not sure I understand what you are trying to do, so I may be off with this, but you could just match against it

    With Sheets("Orders")
    
        arr = Application.Transpose(Application.Transpose(.Range(.Range("A1"), .Cells(1, .Columns.Count).End(xlToLeft))))
    End With
    
    For j = LBound(arrHeaders) To UBound(arrHeaders)
        If Not IsError(Application.Match(arrHeaders(j), arr, 0)) Then
            ' do your stuff
        End If
    Next j

Dropping the range into an array seems a tad pointless as there is no looping over the range, but the rest is okay.

[fredlo2010]

Hi guys thanks for the help. I will explain the problem because I think its not clear.

I have a sheet with data. That sheet comes full with columns that I don't need. I want to remove all those unwanted columns and only keep the ones I want.
Some of those headers are even duplicates.

Here there is a sample
Sample.xlsx

SamT,
I tried your solution but I get an error 9' subscript out of range. on the line bellow.

arr(HeaderNum) = Cells(1, Col).Resize(Lrow, 1).Value

This is getting little complicated because I want to use a multidimensional array. I could just back and forth copying the data I need between the sheets.

I hope this makes the post more clear.

[Bob Phillips]

But loading a multi-dimensional array is trivial, so I still am not sure as to the problem.

As to the sample, why not just delete the columns you don't want before loading, you don't have to save those changes.

[fredlo2010]

Thanks for the help guys.

I was just trying to use an array for this. I already have a code for it. I just wanted to modify it.

This code does the job:

Option Explicit
Sub GetData()

Dim shTarget As Worksheet
Dim shSource As Worksheet
Dim arr As Variant
Dim r As Range
Dim Header As Range
Dim i As Long
Dim lRow As Long

Set shTarget = Sheets("Final Orders")
Set shSource = Sheets("Orders")

lRow = shSource.Cells(Rows.Count, "A").End(xlUp).Row
arr = Array("Sales order", "Name", "Record", "Order type")

Set Header = shSource.Cells(1, 1).Resize(1, shSource.Range("A1").CurrentRegion.Columns.Count)

For i = 0 To UBound(arr)
    Set r = Header.Find(What:=arr(i))
    shTarget.Cells(1, i + 1).Resize(lRow, 1).Value = r.Resize(lRow, 1).Value
Next i

' Final touch ups
With shTarget.Range("A1").CurrentRegion.Columns
    .AutoFit
    .Resize(1).Font.Bold = True
End With

' Release the variables
Set shTarget = Nothing
Set shSource = Nothing
Set r = Nothing
Set Header = Nothing

End Sub

Thanks

[nilem]

Hi Fredlo2010,
try

Sub GetData22()
Dim x, s$, t$, i&, j&, k&, arr
x = Sheets("Orders").Range("A1").CurrentRegion.Value
arr = Array("Sales order", "Name", "Job Site Record", "Order type")
s = "~" & Join(arr, "~") & "~"

For j = 1 To UBound(x, 2)
    t = "~" & x(1, j) & "~"
    If InStr(s, t) Then
        k = k + 1: s = Replace(s, t, "~")
        For i = 1 To UBound(x)
            x(i, k) = x(i, j)
        Next i
    End If
Next j
Sheets("Final Orders").Range("A1").Resize(UBound(x), k).Value = x
End Sub