VBA Code to Open Workbook and copy data

**Howardc** · 08-14-2012, 08:00 PM

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** · 08-14-2012, 08:51 PM

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/

**Howardc** · 08-14-2012, 09:27 PM

**Admin** · 08-14-2012, 09:49 PM

Hi

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

**Howardc** · 08-14-2012, 10:24 PM

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** · 08-14-2012, 10:42 PM

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

**Howardc** · 08-15-2012, 08:51 AM

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** · 08-15-2012, 09:15 AM

Hi

Replace

"xls*"

with

"*"

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

**Howardc** · 08-15-2012, 09:40 AM

Hi

Thanks for the help, much appreciated

**Howardc** · 08-15-2012, 11:06 AM

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