Add the first line of the array

[alex_5]

Hello Excel Forum

I want to add column headers to the first row in the array so how can I not lose their data

Sub RevisedLoadArray()
Dim DBA As Object, RES As Object, SQL As String
Dim Name_Sheet As String
Set DBA = CreateObject("ADODB.Connection")
Dim My_Array()
Dim Ar
Dim i, ii, C As Long
Set DBA = New ADODB.Connection
Set RES = New ADODB.Recordset
    
    Nm = "aa.xls"
    DBPath = "C:\Users\user\Desktop\" & Nm
    
    With DBA
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & DBPath & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
        .Open
    End With
    
    Name_Sheet = "Tst"
    SQL = "SELECT * FROM" & "[" & Name_Sheet & "$]" & ""
    
    Set RES = DBA.Execute(SQL)


ReDim My_Array(1, 30)
For ii = 0 To RES.Fields.Count - 1
        My_Array(1, C) = RES.Fields(ii).Name
        C = C + 1
Next ii


 Do While Not RES.EOF
     C = C + 1
     For i = 0 To RES.Fields.Count - 1
       ii = ii + 1
        My_Array(ii, C) = RES.Fields(i)
      Next
     RES.MoveNext
  Loop
ReDim Preserve My_Array(UBound(Vluse, 2) + 1, UBound(Vluse, 1) + 1)


Range("A1").Resize(UBound(My_Array, 2), UBound(My_Array, 1)) = My_Array
    
    RES.Close: Set RES = Nothing: Erase My_Array
    DBA.Close: Set DBA = Nothing
End Sub

 

[alex_5]

to upload

 

[RoryA]

Why add them to the array? Just write them out to the sheet and then write the array below that (or use copyfromrecordset instead).

 

[alex_5]

The number of data in the sheet is about 15 thousand rows
After I add it to the array I want to look for a particular value in the array only

 

[alex_5]

This is an example

Function My_Tr()  Dim Arr As Variant  Dim P$, Wrbok$  Dim Rx, Clx, i, Cl, Rw, C, M1, M2, Se  P = TextBox5  Application.ScreenUpdating = False  Application.EnableEvents = False  Application.Calculation = xlCalculationManual  Wrbok = "C:\Users\abdulrhman\Desktop\My_Book.xlsx"Arr = GetObject(Wrbok).Worksheets("Sheet1").Range("A1:AD15000").ValueRx = 50  'Clx = 6 'For i = LBound(Arr, 1) To UBound(Arr, 1)    If Arr(i, 1) = Rx Then        Rw = i    End If    For C = LBound(Arr, 2) To UBound(Arr, 2)        If i = 1 Then            If Arr(1, C) = Clx Then                Cl = C            End If        End If    Next CNext iOn Error Resume NextWith WorksheetFunction    M1 = Rw    M2 = Cl    Se = .Index(Arr, M1, M2)End With   If Rw And Cl Then My_Tr = SeOn Error GoTo 0  Application.ScreenUpdating = True  Application.EnableEvents = True  Application.Calculation = xlCalculationAutomatic  Application.CutCopyMode = FalseEnd Function

 

[alex_5]

Function My_Tr()
  Dim Arr As Variant
  Dim P$, Wrbok$
  Dim Rx, Clx, i, Cl, Rw, C, M1, M2, Se
  P = TextBox5
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  Wrbok = "C:\Users\abdulrhman\Desktop\My_Book.xlsx"
Arr = GetObject(Wrbok).Worksheets("Sheet1").Range("A1:AD15000").Value
Rx = 50  '
Clx = 6 '
For i = LBound(Arr, 1) To UBound(Arr, 1)
    If Arr(i, 1) = Rx Then
        Rw = i
    End If
    For C = LBound(Arr, 2) To UBound(Arr, 2)
        If i = 1 Then
            If Arr(1, C) = Clx Then
                Cl = C
            End If
        End If
    Next C
Next i
On Error Resume Next
With WorksheetFunction
    M1 = Rw
    M2 = Cl
    Se = .Index(Arr, M1, M2)
End With
   If Rw And Cl Then My_Tr = Se
On Error GoTo 0
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.CutCopyMode = False
End Function

 

[alex_5]

to upload

 

[alidroos]

This modification to the code

Sub RevisedLoadArray()
Dim DBA As Object, RES As Object, SQL As String
Set DBA = CreateObject("ADODB.Connection")
Dim My_Array()
Dim My_Arry
Dim i, ii, C As Long
Dim Filename$
'-------------------------------------------------------------
Const Path_A As String = "C:\Users\user\Desktop\My_Book.xlsx"
Const Name_Sheet As String = "Sheet1" '
'-------------------------------------------------------------
Set DBA = New ADODB.Connection
Set RES = New ADODB.Recordset
'-------------------------------------------------------------
    With DBA
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & Path_A & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
        .Open
    End With
'-------------------------------------------------------------
    SQL = "SELECT * FROM" & "[" & Name_Sheet & "$]" & ""
    Set RES = DBA.Execute(SQL)
'-------------------------------------------------------------
 Do While Not RES.EOF
     C = C + 1
     For i = 0 To RES.Fields.Count - 1
       ii = ii + 1
       If ii > RES.Fields.Count Then ii = 1
       ReDim Preserve My_Array(1 To RES.Fields.Count + 1, 1 To 15000)
        My_Array(ii, 1) = RES.Fields(i).Name
        My_Array(ii, C + 1) = RES.Fields(i)
      Next
     RES.MoveNext
  Loop
'-------------------------------------------------------------
  My_Arry = Application.Transpose(My_Array)
'-------------------------------------------------------------
RES.Close: Set RES = Nothing: Erase My_Array
DBA.Close: Set DBA = Nothing
End Sub