Results 1 to 15 of 15
  1. #1
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts

    Macro to open specific workbooks and copy data

    I have code below to open up workbooks by having to select each workbook and to copy from sheet 4 (Source workbooks) to sheet2 (Destination workbook) after the last row containing data

    I would like the code amended so as to open and copy data from the workbooks below

    Your assistance in this regard is most appreciated


    The workbooks are

    Valtb.xls
    Vaptb.xls
    Nrtb.xls
    Netb.xls
    Crltb.xls

    Code:
     Sub Open_BSWorkbook()
    A:
    Dim A     As Variant
        
        ChDir "C:\My documents"
        A = Application.GetOpenFilename
        If A = False Or IsEmpty(A) Then Exit Sub
        
        Application.ScreenUpdating = False
        
        With Workbooks.Open(A)
            With .Sheets(4)
                .Range("a2", .Range("d" & Rows.Count).End(xlUp)).Copy _
                    Destination:=ThisWorkbook.Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1)
            End With
            .Close SaveChanges:=False
        End With
       answer = MsgBox("Does another file needs to be selected?", vbYesNo + vbQuestion, "Hello")
    If answer = vbYes Then
    GoTo A:
    End If
    Application.ScreenUpdating = True
        
    End Sub

  2. #2
    New Lounger
    Join Date
    Nov 2014
    Posts
    21
    Thanks
    16
    Thanked 1 Time in 1 Post
    Howard,

    Would this work?
    Code:
    Sub Open_BSWorkbook()
    A:
    Dim A     As Variant
        
    ChDir "C:\My documents"
    A = Application.GetOpenFilename
    B = "C:\My documents"
    If A = False Or IsEmpty(A) Or A <> B & "Valtb.xls" Or A <> B & "Vaptb.xls" Or A <> B & "Nrtb.xls" Or A <> B & "Netb.xls" Or A <> B & "Crltb.xls" Then Exit Sub
        
        Application.ScreenUpdating = False
        
        With Workbooks.Open(A)
            With .Sheets(4)
                .Range("a2", .Range("d" & Rows.Count).End(xlUp)).Copy _
                    Destination:=ThisWorkbook.Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1)
            End With
            .Close SaveChanges:=False
        End With
       answer = MsgBox("Does another file needs to be selected?", vbYesNo + vbQuestion, "Hello")
    If answer = vbYes Then
    GoTo A:
    End If
    Application.ScreenUpdating = True
        
    End Sub
    Nicole
    Last edited by Nicole545; 2016-06-25 at 13:44.

  3. #3
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Thanks for the reply Nicole

    No data is being copied

    I need the workbooks to be automatically opened and the data copied from A2 to the last row in Col D from sheet 4 in the source workbook to A2 on Sheet 2 in the destination workbook

    It would be appreciated if you would amend your code

  4. #4
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,629
    Thanks
    114
    Thanked 644 Times in 588 Posts
    Howard,

    1. Add a "\" to the end of the line B = "C:\My documents" so it reads:
    B = "C:\My documents\"

    2. Change the "OR"s to "And"s:
    Code:
    If A = False Or IsEmpty(A) Or A <> B & "Valtb.xls" And _
    A <> B & "Vaptb.xls" And A <> B & "Nrtb.xls" And _
    A <> B & "Netb.xls" And A <> B & "Crltb.xls" Then Exit Sub
    HTH,
    Maud
    Last edited by Maudibe; 2016-06-25 at 17:43.

  5. The Following User Says Thank You to Maudibe For This Useful Post:

    Nicole545 (2016-06-26)

  6. #5
    New Lounger
    Join Date
    Nov 2014
    Posts
    21
    Thanks
    16
    Thanked 1 Time in 1 Post
    Ahhh... I see the less than optimal mistakes in my logic. Totally missed the missing "\". Thank you for fixing it.

    Nicole

  7. #6
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    Thanks for your help. The code still requires me to select the workbooks to open and when I do no data is copied and pastd into the destination workbook

    The Code in Post # 1 works perfectly. The only change I wanted was to enable me to automatically open the workbooks and copy the data

  8. #7
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,629
    Thanks
    114
    Thanked 644 Times in 588 Posts
    The Code in Post # 1 works perfectly
    Howard,

    Thanks for clarifying your intent. Since you said your code works fine, I wrapped it in the code needed to automatically open only the 5 files you specified.

    HTH,
    Maud

    Code:
    Public Sub ListFiles()
    Application.ScreenUpdating = False
    On Error Resume Next
    '--------------------------------------------
    'DECLARE AND SET VARIABLES
    Path = "C:\My Documents"
    Filename = Dir(Path & "\*.*")
    '--------------------------------------------
    'GET FILENAMES AND COMPARE TO OPEN LIST
     Do While Len(Filename) > 0
        Select Case Filename
            Case "Valtb.xls", "Vaptb.xls", "Nrtb.xls", "Netb.xls", "Crltb.xls"
    '=========================
    'YOUR CODE START
                With Workbooks.Open(Filename)
                    With .Sheets(4)
                        .Range("a2", .Range("d" & Rows.Count).End(xlUp)).Copy _
                        Destination:=ThisWorkbook.Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1)
                    End With
                    .Close SaveChanges:=False
                End With
    '=========================
    'YOUR CODE END
        End Select
        Filename = Dir
    Loop
    '--------------------------------------------
    Application.ScreenUpdating = True
    End Sub

  9. The Following User Says Thank You to Maudibe For This Useful Post:

    HowardC (2016-06-26)

  10. #8
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Thanks for thehelp Maud

  11. #9
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    I tried to adapt your code to another worksheet, but nothing is pasted into the destination workbook

    I need to open up a workbook "CRE TB Consolidation IS & BS.xls" and copy the data from sheet1 from A2 to the last row in Col C and paste this in I4 onwards on sheet7 in the destination workbook

    It would be appreciated if you could kindly assist me

    Code:
    Public Sub ListFiles()
    Application.ScreenUpdating = False
    On Error Resume Next
    '--------------------------------------------
    'DECLARE AND SET VARIABLES
    Path = "C:\Accounting Data"
    Filename = Dir(Path & "\*.*")
    '--------------------------------------------
    'GET FILENAMES AND COMPARE TO OPEN LIST
     Do While Len(Filename) > 0
        Select Case Filename
            Case "CRE TB Consolidation IS & BS.xls"
    '=========================
    'YOUR CODE START
                With Workbooks.Open(Filename)
                    With .Sheets(1)
                        .Range("a2", .Range("c" & Rows.Count).End(xlUp)).Copy _
                        Destination:=ThisWorkbook.Sheets(7).Range("I" & Rows.Count).End(xlUp)
                    End With
                    .Close SaveChanges:=False
                End With
    '=========================
    'YOUR CODE END
        End Select
        Filename = Dir
    Loop
    '--------------------------------------------
    Application.ScreenUpdating = True
    End Sub
    Last edited by HowardC; 2016-07-05 at 09:00.

  12. #10
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,629
    Thanks
    114
    Thanked 644 Times in 588 Posts
    Howard,

    I modified a segment of your original code (modifications in blue)

    Code:
    Public Sub ListFiles()
    Application.ScreenUpdating = False
    On Error Resume Next
    '--------------------------------------------
    'DECLARE AND SET VARIABLES
    Path = "C:\Accounting Data"
    Filename = Dir(Path & "\*.*")
    '--------------------------------------------
    'GET FILENAMES AND COMPARE TO OPEN LIST
     Do While Len(Filename) > 0
        Select Case Filename
            Case "CRE TB Consolidation IS & BS.xls"
    '=========================
    'YOUR CODE START
                With Workbooks.Open(Path & "\" & Filename)
                    With .Sheets(1)
                        .Range("A2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Copy _
                        Destination:=ThisWorkbook.Sheets(7).Range("I2")
                    End With
                    .Close SaveChanges:=False
                End With
    
    '=========================
    'YOUR CODE END
        End Select
        Filename = Dir
    Loop
    '--------------------------------------------
    Application.ScreenUpdating = True
    End Sub
    HTH,
    Maud

  13. The Following User Says Thank You to Maudibe For This Useful Post:

    HowardC (2016-07-06)

  14. #11
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    Thanks very much for the help. Code works perfectly. I have been through your code and fully understand how it works


    Howard

  15. #12
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,629
    Thanks
    114
    Thanked 644 Times in 588 Posts
    Howard,

    Glad to know that you can follow the code and the code from others. You have come a long way my friend!

  16. The Following User Says Thank You to Maudibe For This Useful Post:

    HowardC (2016-07-07)

  17. #13
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Thanks for the compliment Maud

    I tried to make one small change to your code, so when the data is copied, it value pastes the data.

    Your code

    Code:
     With .Sheets(1)
                        .Range("A2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Copy _
                      Destination:=ThisWorkbook.Sheets(7).Range("I2") 


    However, when amending the code in blue above to code below I get a syntax error (see code in blue)

    Code:
     With .Sheets(1)
                        .Range("A1:W" & Cells(Rows.Count, "C").End(xlUp).Row).Copy _
                      Destination:=ThisWorkbook.Sheets(1).Range("A1").PasteSpecial XLPasteValues 


    It would be appreciated if you could kindly amend this
    Last edited by HowardC; 2016-07-07 at 06:10.

  18. #14
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,420
    Thanks
    124
    Thanked 5 Times in 5 Posts
    Hi Maud

    Managed to sort this out by amending

    Code:
    ThisWorkbook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
    to

    Code:
     Destination:=ThisWorkbook.Sheets(1).Range("A1").PasteSpecial XLPasteValues

  19. The Following User Says Thank You to HowardC For This Useful Post:

    Maudibe (2016-07-07)

  20. #15
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,629
    Thanks
    114
    Thanked 644 Times in 588 Posts
    Nice job Howard!

Tags for this Thread

Posting Permissions

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