VBA Code to Open Workbook and copy data

[Howardc]

I have several workbook that I need to open and copy the data into sheet1 of the destinational workbook

All the headers in the source workbook are the same

I would like VBA code to do the following

1) To copy the data including headings from the first workbook in sheet1 on the destination workbook
2) All subsequent workbooks, except headers to be copied in the row after vwhere the previous data has been copies

I have attached a sample workbook

Your assistance in this regard is most appreciated

[Admin]

Hi

I haven't looked at your attachment yet. Try the code I posted in the following link. Let me know how it goes.

http://www.excelfox.com/forum/f2/macro-opening-files-copy-contents-file-513/

[Howardc]

Hi

When activating the macro, it allow me to select a folder, but It does lnot allow me to view the workbooks which I need to select-+see screen shot attached. I would be appreciated if you would amend your macro so that I can test further


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg (https://www.youtube.com/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eekDyfS0 CD)
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c (https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg.9edGvmwOLq99eevG7txd 2c)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzytUUVRyw9U55-6M54AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgzCoa6tOVIBxRDDDbN4AaABAg)
https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr (https://www.youtube.com/watch?v=9P6r7DLS77Q&lc=UgyriWOelbVnw4FHWT54AaABAg.9dPo-OdLmZ09dc21kigjmr)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzDQfo5rJqyVwvv2r54AaABAg)
https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf (https://www.youtube.com/watch?v=363wd2EtQZ0&lc=UgzHTSka7YppBdmUooV4AaABAg.9cXui6zzkz09cZttH_-2Gf)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[Admin]

Hi

Create a folder and move all those files into the new folder and try again the code.

[Howardc]

Hi

I have created a new folder and moved the files to the new folder. When activating the maxro, it allow me to select a folder, but I cannot see any of the files. I have attached one of the source workbooks (BR1 Pay) as well as the destination workbook Payroll Extraxt.2012 containing the macro. It would be appreciated if you will test the macro and make the necessary changes

[Admin]

Hi,

You only need to select the folder. I tweaked the code little bit.

Use this code.


Dim dic As Object
Dim Counter As Long
Sub kTest()

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 = "xls*" 'xls,xlsx,xlsb,xlsm
Const DestinationSheet As String = "Sheet1"
Const DestStartCell As String = "A1"
'// 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 50000, 1 To 100)
Set Dest = wbkActive.Worksheets(DestinationSheet).Range(DestS tartCell)
Fname = Dir(Fldr & "\*." & SourceFileType)
Do While Len(Fname)
If wbkActive.Name <> Fname Then
Set wbkSource = Workbooks.Open(Fldr & "\" & Fname)
With wbkSource.Worksheets(1)
If WorksheetFunction.CountA(.Rows(1)) = 0 Then .Rows(1).Delete
d = .Range("a1").CurrentRegion
UniqueHeaders Application.Index(d, 1, 0)
For r = 2 To UBound(d, 1) 'skips header
If Len(d(r, 1)) Then
n = n + 1
For c = 1 To UBound(d, 2)
If Len(Trim$(d(1, c))) Then
j = dic.Item(Trim$(d(1, 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", vbInformation, "ExcelFox.com"
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

Thanks for amending the code. It extraxts the data ffrom all the files perfectly. it would be apppreciated if you could amend the code to extract Excel as well as files with CSV format

I tried to amend the code Const SourceFileType As String = "xls*" 'xls,xlsx,xlsb,xlsm to Const SourceFileType Const SourceFileType As String = ["xls*", "csv"] 'xls,xlsx,xlsb,xlsm, but cannot get it to work

Regards

Howard

[Admin]

Hi

Replace

"xls*"

with

"*"

Ensure, only xls*, csv files should be there in the folder.

[Howardc]

Hi

Thanks for the help, much appreciated

[Howardc]

Hi

I have re-tested the code and It would be appreciated if you could make the following small change. The first row of the data contains the Branch name and the decsription. the second row contains the row headings. The first row must be ignored. The headers in the second row must be extracted for the first file and the rest of the files from row three onwards

I have attached sample data of one of the source workbooks as well as what the data extraction looks like in the destination workbook

[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(DestS tartCell)
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. :cheers: