VBA Code to Open Workbook and copy data

[Admin]

Hi

Replace the following lines

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

with

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

[Howardc]

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

[Admin]

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.

[Howardc]

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

[Admin]

Hi,

OK. use this.

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

[Howardc]

Hi Admin

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

[Admin]

Thanks for the feedback.