VBA Code to Open Workbook and copy data

Hi

Replace the following lines

Code:

---

UniqueHeaders Application.Index(d, 1, 0)
For r = 2 To UBound(d, 1) 'skips header

---

with

Code:

---

UniqueHeaders Application.Index(d, 2, 0)'second row holds the header
For r = 3 To UBound(d, 1) 'skips header

---

Hi

Thanks for the reply & your help

When activating the macro, it now comes up with run time error 9 "subscript out of range" and the folowing code is highlighted

k(n, j) = d(r, c)

It would be appreciated if you would amend your code and advise accordingly

Hi,

When it errors, click on debug and move the cursor over n and j and find the value. If the current value is greater than 50000 and 100 of n and j respectively, then replace the statement

redim k(1 to 50000,1 to 100)

with

redim k(1 to 100000,1 to 200)

or whatever the maximum possible rows or columns of output data.

Hi

Thanks for the reply. I clicked on debug and hovered over N and it gives me N= 1 , J = 0

It would be appreciated if you would test your code on the attached files & let me know

Hi,

OK. use this.

Code:

---

Dim dic            As Object
Dim Counter        As Long
Sub Extraxt_Data()
   
    Dim r          As Long
    Dim c          As Long
    Dim n          As Long
    Dim j          As Long
    Dim Fldr        As String
    Dim Fname      As String
    Dim wbkActive  As Workbook
    Dim wbkSource  As Workbook
    Dim Dest        As Range
    Dim d, k()
   
    '// User settings
    Const SourceFileType        As String = "*"
    Const DestinationSheet      As String = "Sheet1"
    Const DestStartCell        As String = "A1"
    Const HeaderRow            As Long = 2
    '// End
   
    Application.ScreenUpdating = False
    Counter = 0
    With Application.FileDialog(4)
        .Title = "Select source file folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            Fldr = .SelectedItems(1)
        Else
            GoTo Xit
        End If
    End With
   
   
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    Set wbkActive = ThisWorkbook
    ReDim k(1 To 10000, 1 To 200)
    Set Dest = wbkActive.Worksheets(DestinationSheet).Range(DestStartCell)
    Fname = Dir(Fldr & "\*." & SourceFileType)
    Do While Len(Fname)
        If wbkActive.Name <> Fname Then
            Set wbkSource = Workbooks.Open(Fldr & "\" & Fname)
            With wbkSource.Worksheets(1)
                d = .Range("a1").CurrentRegion.Value2
                UniqueHeaders Application.Index(d, HeaderRow, 0)
                For r = HeaderRow + 1 To UBound(d, 1)
                    If Len(d(r, 1)) Then
                        n = n + 1
                        For c = 1 To UBound(d, 2)
                            If Len(Trim$(d(HeaderRow, c))) Then
                                j = dic.Item(Trim$(d(HeaderRow, c)))
                                k(n, j) = d(r, c)
                            End If
                        Next
                    End If
                Next
                Erase d
            End With
            wbkSource.Close 0
            Set wbkSource = Nothing
        End If
        Fname = Dir()
    Loop
   
    If n Then
        Dest.Resize(, dic.Count) = dic.keys
        Dest.Offset(1).Resize(n, dic.Count) = k
        MsgBox "Done"
    End If
Xit:
    Application.ScreenUpdating = True
   
End Sub
Private Sub UniqueHeaders(ByRef DataHeader)
   
    Dim i  As Long
    Dim j  As Long
   
    With Application
        j = .ScreenUpdating
        .ScreenUpdating = False
    End With
   
    For i = LBound(DataHeader) To UBound(DataHeader)
        If Len(Trim$(DataHeader(i))) Then
            If Not dic.exists(Trim$(DataHeader(i))) Then
                Counter = Counter + 1
                dic.Add Trim$(DataHeader(i)), Counter
            End If
        End If
    Next
   
    Application.ScreenUpdating = j
   
End Sub

---

Hi Admin

You are a star. The code works perfectly. Thanks for all the time and effort in sorting out the problem

Thanks for the feedback. :cheers: