none
COPY DATA FROM ONE WORK BOOK TO ANOTHER RRS feed

  • Question

  • trying to use below code to copy a range from one workbook and paste to another workbook.

    getting a 400 error. any help would be appreciated

    thanks

    doug

     Sub ballparkdatacopy()
     
     ThisWorkbook.Save
      Application.ScreenUpdating = False
     
     Dim R As Long
     Dim FNAME As String
     
      MYPATH = MYPATHIS()
     strFolder = MYPATH
     
    FNAME = "1 2018 ESTIMATE A1.0.xlsm"
    If Dir(MYPATH & FNAME) <> "" Then
    Workbooks.Open strFolder & FNAME 'MASTER FILE
     Else
     MsgBox ("FILE NOT FOUND")
    End If
      '<<<***CHECKS IF ENTRY EXISTS...IF SO OVERWRITE***>>>
     
    ThisWorkbook.Sheets("DATA").Range("J131:R131").Select 'RANGE TO COPY
    Selection.Copy
    For Each X In Workbooks(FNAME).Sheets("BALLPARK").Range("K2:K601")
    If X = ThisWorkbook.Sheets("DATA").Range("J131") Then
    Workbooks(FNAME).Sheets("BALLPARK").Activate
    X.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Workbooks(FNAME).Close True 'CLOSE MASTER
        Else
       
          '<<<***paste to next open cell in range***>>>
         
        If WorksheetFunction.CountIf(Workbooks(FNAME).Sheets("BALLPARK").Range("k2:k601"), "") > 0 Then
      
       R = Workbooks(FNAME).Sheets("BALLPARK").Range("k1:k602").Find(what:="", searchorder:=xlByRows, searchdirection:=xlNext).Row
      
       ThisWorkbook.Sheets("DATA").Range("J131:r131").Copy
      
        Workbooks(FNAME).Sheets("BALLPARK").Activate
       
       Cells(R, "k").PasteSpecial xlPasteValues
       Application.CutCopyMode = False
      
       Workbooks(FNAME).Close True 'CLOSE WORK
       
        Else
       
          Workbooks(FNAME).Close True 'CLOSE WORK
         
         Call moveballparkdata 'delete first entry - move data up
        
         End If
        
       End If
         Next
        
    Worksheets("DATA").Activate
        
    End Sub

    Monday, July 30, 2018 4:07 PM

Answers

  • hi Terry,

    changed the code to below and it now appears to work. I think the issue was somehow related to referencing between two workbooks.

    thanks

    Doug

    Sub ballparkdatacopy()

     Application.ScreenUpdating = False
    '<<<***STEP 1: OPEN MASTER WORKBOOK***>>>
     MYPATH = MYPATHIS()
      strFolder = MYPATH
      Dim FNAME As String
     FNAME = "1 2018 ESTIMATE A1.0.xlsm"
     
    If Dir(MYPATH & FNAME) <> "" Then

    Workbooks.Open strFolder & FNAME
    Workbooks(FNAME).Windows(1).Visible = False 'TRY THIS
    Else
     MsgBox ("FILE NOT FOUND")
    End If

      '<<<***STEP 2: COPY DATA ("J131:R131") TO ("K603") ON MASTER***>>>
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K603:S603").Clear
     
      ThisWorkbook.Sheets("DATA").Range("J131:R131").Select 'RANGE TO COPY
    Selection.Copy
    Workbooks(FNAME).Sheets("BALLPARK").Range("K603").PasteSpecial xlPasteValues

    Application.CutCopyMode = False

    '*STEP 3: CHECK IF QUOTE ("K103") ALEADY EXISTS ON MASTER ("K2:K601") - IF SO OVERWRITE DATA AND EXIT SUB

    Workbooks(FNAME).Sheets("BALLPARK").Activate

    For Each a In ActiveSheet.Range("k2:k601")
     If a = ActiveSheet.Range("k603") Then
     
     ActiveSheet.Range("k603:s603").Select
     Selection.Copy
     a.PasteSpecial xlPasteValues
     
    Workbooks(FNAME).Windows(1).Visible = True
    Workbooks(FNAME).Close True 'CLOSE MASTER FILE
     
     Exit Sub

    End If
    Next

    '<<<***STEP 4: IF ("K603") DOES NOT ALREADY EXIST ON MASTER THEN PASTE ("K603:S603")TO NEXT BLANK ROW IN ("K2:K601")

    Workbooks(FNAME).Sheets("BALLPARK").Activate

     For Each a In ActiveSheet.Range("k2:k601")
     If a = "" Then
     
     ActiveSheet.Range("k603:s603").Select
     Selection.Copy
     
     a.PasteSpecial xlPasteValues
     
    Workbooks(FNAME).Windows(1).Visible = True
    Workbooks(FNAME).Close True 'CLOSE MASTER FILE
     
     Exit Sub
     
     Else
     
      '<<<***STEP 5: IF MASTER ("K2:S601") IS FULL CALL SUB TO DELETE ("K2:S2"), OLDEST ENTRY,
                     'AND MOVE ("K3:S601") UP ONE ROW TO FREE UP ROW AT END OF TABLE
                     'IDEA IS ONCE RANGE IS FULL CONSTANTLY MOVE OUT THE OLDEST AND ADD NEW
     
     Workbooks(FNAME).Windows(1).Visible = True 'TRY THIS
     Workbooks(FNAME).Close True
     
     
     thisworkbooks.Sheets("DATA").Activate
     
     Call moveballparkdata
     
     End If
     
     Next
     
     Workbooks(FNAME).Windows(1).Visible = True
    Workbooks(FNAME).Close True
         
    ThisWorkbook.Sheets("DATA").Activate
    Range("A1").Select
         End Sub
     
     '<<<EDIT as req'd
     
     Sub moveballparkdata()
     
      ThisWorkbook.Save
      Application.ScreenUpdating = False
     
     Dim r As Long
     Dim FNAME As String
     
      MYPATH = MYPATHIS()
     strFolder = MYPATH
     
    FNAME = "1 2018 ESTIMATE A1.0.xlsm"
    If Dir(MYPATH & FNAME) <> "" Then
    Workbooks.Open strFolder & FNAME
     Else
     MsgBox ("FILE NOT FOUND")
    End If
     
     
     Workbooks(FNAME).Activate
    'Worksheets("BALLPARK").Activate
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K2:S2").Clear
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K3:s601").Select
     Selection.Copy
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K2").PasteSpecial xlPasteValues
     Application.CutCopyMode = False
     
     Workbooks(FNAME).Close True 'CLOSE WORK
     Worksheets("DATA").Activate
     
      Call ballparkdatacopy
     
     End Sub

    • Marked as answer by 6da4 Tuesday, July 31, 2018 12:09 PM
    Tuesday, July 31, 2018 12:08 PM

All replies

  • Hello doug,

    Which line caused the error? What's the detail error message? 

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, July 31, 2018 2:00 AM
  • hi Terry,

    changed the code to below and it now appears to work. I think the issue was somehow related to referencing between two workbooks.

    thanks

    Doug

    Sub ballparkdatacopy()

     Application.ScreenUpdating = False
    '<<<***STEP 1: OPEN MASTER WORKBOOK***>>>
     MYPATH = MYPATHIS()
      strFolder = MYPATH
      Dim FNAME As String
     FNAME = "1 2018 ESTIMATE A1.0.xlsm"
     
    If Dir(MYPATH & FNAME) <> "" Then

    Workbooks.Open strFolder & FNAME
    Workbooks(FNAME).Windows(1).Visible = False 'TRY THIS
    Else
     MsgBox ("FILE NOT FOUND")
    End If

      '<<<***STEP 2: COPY DATA ("J131:R131") TO ("K603") ON MASTER***>>>
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K603:S603").Clear
     
      ThisWorkbook.Sheets("DATA").Range("J131:R131").Select 'RANGE TO COPY
    Selection.Copy
    Workbooks(FNAME).Sheets("BALLPARK").Range("K603").PasteSpecial xlPasteValues

    Application.CutCopyMode = False

    '*STEP 3: CHECK IF QUOTE ("K103") ALEADY EXISTS ON MASTER ("K2:K601") - IF SO OVERWRITE DATA AND EXIT SUB

    Workbooks(FNAME).Sheets("BALLPARK").Activate

    For Each a In ActiveSheet.Range("k2:k601")
     If a = ActiveSheet.Range("k603") Then
     
     ActiveSheet.Range("k603:s603").Select
     Selection.Copy
     a.PasteSpecial xlPasteValues
     
    Workbooks(FNAME).Windows(1).Visible = True
    Workbooks(FNAME).Close True 'CLOSE MASTER FILE
     
     Exit Sub

    End If
    Next

    '<<<***STEP 4: IF ("K603") DOES NOT ALREADY EXIST ON MASTER THEN PASTE ("K603:S603")TO NEXT BLANK ROW IN ("K2:K601")

    Workbooks(FNAME).Sheets("BALLPARK").Activate

     For Each a In ActiveSheet.Range("k2:k601")
     If a = "" Then
     
     ActiveSheet.Range("k603:s603").Select
     Selection.Copy
     
     a.PasteSpecial xlPasteValues
     
    Workbooks(FNAME).Windows(1).Visible = True
    Workbooks(FNAME).Close True 'CLOSE MASTER FILE
     
     Exit Sub
     
     Else
     
      '<<<***STEP 5: IF MASTER ("K2:S601") IS FULL CALL SUB TO DELETE ("K2:S2"), OLDEST ENTRY,
                     'AND MOVE ("K3:S601") UP ONE ROW TO FREE UP ROW AT END OF TABLE
                     'IDEA IS ONCE RANGE IS FULL CONSTANTLY MOVE OUT THE OLDEST AND ADD NEW
     
     Workbooks(FNAME).Windows(1).Visible = True 'TRY THIS
     Workbooks(FNAME).Close True
     
     
     thisworkbooks.Sheets("DATA").Activate
     
     Call moveballparkdata
     
     End If
     
     Next
     
     Workbooks(FNAME).Windows(1).Visible = True
    Workbooks(FNAME).Close True
         
    ThisWorkbook.Sheets("DATA").Activate
    Range("A1").Select
         End Sub
     
     '<<<EDIT as req'd
     
     Sub moveballparkdata()
     
      ThisWorkbook.Save
      Application.ScreenUpdating = False
     
     Dim r As Long
     Dim FNAME As String
     
      MYPATH = MYPATHIS()
     strFolder = MYPATH
     
    FNAME = "1 2018 ESTIMATE A1.0.xlsm"
    If Dir(MYPATH & FNAME) <> "" Then
    Workbooks.Open strFolder & FNAME
     Else
     MsgBox ("FILE NOT FOUND")
    End If
     
     
     Workbooks(FNAME).Activate
    'Worksheets("BALLPARK").Activate
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K2:S2").Clear
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K3:s601").Select
     Selection.Copy
     
     Workbooks(FNAME).Sheets("BALLPARK").Range("K2").PasteSpecial xlPasteValues
     Application.CutCopyMode = False
     
     Workbooks(FNAME).Close True 'CLOSE WORK
     Worksheets("DATA").Activate
     
      Call ballparkdatacopy
     
     End Sub

    • Marked as answer by 6da4 Tuesday, July 31, 2018 12:09 PM
    Tuesday, July 31, 2018 12:08 PM