Load a Multidimensional array

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.

Code:

---

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

Written in VBAX Editor >> UnTested:

Code:

---

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

Code:

---

'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

---

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

Code:

---

    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.

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
Attachment 11110

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

Code:

---

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.

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.

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:

Code:

---

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

Hi Fredlo2010,
try

Code:

---

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

---