Printable View
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
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/mac...ents-file-513/
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/watch?v=tzbKqTRuRzU&lc=UgyYW2WZ2DvSrzUKnJ14AaABAg
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg. 9edGvmwOLq99eekDyfS0CD
https://www.youtube.com/watch?v=UywjKEMjSp0&lc=UgxIySxHPqM1RxtVqoR4AaABAg. 9edGvmwOLq99eevG7txd2c
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=UgzCoa6tOVIBxRDDDbN4AaABAg
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=UgzHTSka7YppBdmUooV4AaABAg. 9cXui6zzkz09cZttH_-2Gf
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
Hi
Create a folder and move all those files into the new folder and try again the code.
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
Hi,
You only need to select the folder. I tweaked the code little bit.
Use this code.
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(DestStartCell)
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
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
Hi
Replace
"xls*"
with
"*"
Ensure, only xls*, csv files should be there in the folder.
Hi
Thanks for the help, much appreciated
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
Hi
Replace the following lines
withCode:UniqueHeaders Application.Index(d, 1, 0)
For r = 2 To UBound(d, 1) 'skips header
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: