Page 1 of 2 12 LastLast
Results 1 to 10 of 17

Thread: VBA Code to Open Workbook and copy data

  1. #1
    Senior Member
    Join Date
    Apr 2012
    Posts
    193
    Rep Power
    13

    VBA Code to Open Workbook and copy data

    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
    Attached Files Attached Files

  2. #2
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    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/
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  3. #3

  4. #4
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi

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

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  5. #5
    Senior Member
    Join Date
    Apr 2012
    Posts
    193
    Rep Power
    13

    VBA Code to Open Workbook and copy data

    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
    Attached Files Attached Files

  6. #6
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    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
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  7. #7
    Senior Member
    Join Date
    Apr 2012
    Posts
    193
    Rep Power
    13
    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

  8. #8
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi

    Replace

    "xls*"

    with

    "*"

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

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  9. #9
    Senior Member
    Join Date
    Apr 2012
    Posts
    193
    Rep Power
    13
    Hi

    Thanks for the help, much appreciated

  10. #10
    Senior Member
    Join Date
    Apr 2012
    Posts
    193
    Rep Power
    13

    VBA Code to Open Workbook and copy data

    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
    Attached Files Attached Files

Similar Threads

  1. Replies: 2
    Last Post: 05-28-2013, 05:32 PM
  2. Replies: 17
    Last Post: 05-22-2013, 11:58 PM
  3. Replies: 7
    Last Post: 05-17-2013, 10:38 PM
  4. Replies: 0
    Last Post: 04-20-2013, 10:07 AM
  5. VBA code to copy data from source workbook
    By Howardc in forum Excel Help
    Replies: 1
    Last Post: 07-30-2012, 09:28 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •