Transferring Data between Workbooks With VBA

[Bill Williamson]

I know I cant be too far off, but I am getting a runtime error when trying to transfer to an open workbook from a different but now open workbook

Sub WeldmentMovingMacro()

' WeldmentMovingMacro Macro
' Enters Data into stainless tracking

' Keyboard Shortcut: Ctrl+w

   
'Opens Destination file.
Workbooks.Open Filename:= _
        "C:\Users\Billw\Desktop\New folder\StainlessDataTest.xlsm"
      

'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

  'Set variables for copy and destination sheets
  Set wsCopy = Workbooks(Active.Workbook.xlsx).Worksheets("Export")    ' This is where I get the ERROR
  Set wsDest = Workbooks("StainlessDataTest.xlsm").Worksheets("All Data")
   
  ' Find last used row in the copy range based on data in column A
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
   
  ' Find first blank row in the destination range based on data in column C
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row

  'Copy& Paste Data
  wsCopy.Range("A2:D" & lCopyLastRow).Copy _
    wsDest.Range("C" & lDestLastRow)
   
End Sub

Thank you,

Bill Williamson

 

[AC PORTA VIA]

change this line of code

Set wsCopy = Workbooks(Active.Workbook.xlsx).Worksheets("Export")    ' This is where I get the ERROR

to

Set wsCopy = Workbooks(name of the workbook.xlsx).Worksheets("Export")

 

[Bill Williamson]

Well now it is making it to the next line of code then getting a Run-time Error (9)
Subscript out of range?

So even when this is working, I will have to change code for the file name every time I want to transfer a different file?
That's disappointing, I will often be doing 10-15 of these a day. The destination file will always be the same but there are many files to extract data from..
Is it Possible to have all the files to be extracted from in one place and then run script on all at once? Maybe a Message Box asking for the file name rather than having to manually change code? Just thinking while typing... Sorry if I am rambling a bit on.

'Opens Destination file.
Workbooks.Open Filename:= _
        "C:\Users\Billw\Desktop\New folder\StainlessDataTest.xlsm"
      

'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

  'Set variables for copy and destination sheets
 
 
  Set wsCopy = Workbooks("GeneralMills E341934012.xlsx").Worksheets("Export")
  Set wsDest = Workbooks("StainlessDataTest.xlsm").Worksheets("All Data")' Getting error on this line now'
    
  'Find last used row in the copy range based on data in column A
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
    
  'Find first blank row in the destination range based on data in column C
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row

  'Copy & Paste Data
  wsCopy.Range("A2:D" & lCopyLastRow).Copy _
    wsDest.Range("C" & lDestLastRow)

'Here are a couple of screen shots from original file and destination file in case they may be helpful.

The plan is when I get this working is to have it Auto date stamp in Column B and Number Column A

Thanks,


Bill

 

[Bill Williamson]

Ok I figured out the Error, The Receiving worksheet name was different then identified in the code.
I still hope to make this work on other files with out code change, if you have any suggestions, I would love to hear them.

Thanks,

Bill

 

[Bill Williamson]

Question, If I used ThisWorkbook, could code be written to insert the actual name of the file automatically?
Thus allowing it to work on any of the files?

 

[AC PORTA VIA]

if all of your workbooks that you copy from have sheet named "Export" you could save every workbook that you open as SaveAs on any location you want and use new workbook name in this line

Set wsCopy = Workbooks("Testworkbook.xlsx").Worksheets("Export")

add Application.DisplayAlerts = False
before SaveAs as you would overwrite that file as many times as you have workbooks to copy from
Your new code below that you can repeat as many times as you have workbooks to copy from

Sub WeldmentMovingMacro()

' WeldmentMovingMacro Macro
' Enters Data into stainless tracking

' Keyboard Shortcut: Ctrl+w

 
'Opens Destination file.
Workbooks.Open Filename:= _
        "C:\Users\Billw\Desktop\New folder\StainlessDataTest.xlsm"
      Application.DisplayAlerts = False
      'Save active workbook to C drive in folder Test as new name Testworkbook.xlsx
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Test\Testworkbook.xlsx", FileFormat:=51

'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

  'Set variables for copy and destination sheets
  Set wsCopy = Workbooks(Testworkbook.xlsx).Worksheets("Export") 
  Set wsDest = Workbooks("StainlessDataTest.xlsm").Worksheets("All Data")
 
  ' Find last used row in the copy range based on data in column A
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
 
  ' Find first blank row in the destination range based on data in column C
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row

  'Copy& Paste Data
  wsCopy.Range("A2:D" & lCopyLastRow).Copy _
    wsDest.Range("C" & lDestLastRow)
   Workbooks("Testworkbook.xlsx").Close False
   Application.DisplayAlerts = True
End Sub

 

[Bill Williamson]

Hello AC,

I have not had the opportunity to test the code yet. Question, does the workbook I am going to copy the Data from, need to be saved to accomplish this action?
Currently I get a six page report from another program,
I was saving this file with the Customer Name and CSO# in the Workbook name.

I would then run a macro to sort the data, knocking it down to less than a page, the code would also pull
the info from the file name to populate a couple of rows on the sheet, then saves it.

I was then going to run a second macro to transfer the data to the Master sheet.

If it does have to be saved I could use maybe a temp name as you suggested.
Either way I could just try make a msgbox ask for Customer name and CSO Number,
Then the file name will no longer be any issue for my needs.
if I can use one macro to do it all saves me time.
Sorry to be so long winded, I am very new to VBA.
Might take me a minute to figure that part out.

Thanks for your time and patience.

Bill

 

[AC PORTA VIA]

Question, does the workbook I am going to copy the Data from, need to be saved to accomplish this action? - no you don't need too macro will do it for you
all you have to do is open main workbook and leave it open than open workbook that you are going to copy from modified the way you want and ran macro below-that will copy to main workbook and it will close it, then open new workbook , modify again the way you want and ran same macro below
repeat for all workbooks to copy from

sub copy()
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Test\Testworkbook.xlsx", FileFormat:=51

'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

  'Set variables for copy and destination sheets
  Set wsCopy = Workbooks(Testworkbook.xlsx).Worksheets("Export")
  Set wsDest = Workbooks("StainlessDataTest.xlsm").Worksheets("All Data")

  ' Find last used row in the copy range based on data in column A
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

  ' Find first blank row in the destination range based on data in column C
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row

  'Copy& Paste Data
  wsCopy.Range("A2:D" & lCopyLastRow).Copy _
    wsDest.Range("C" & lDestLastRow)
   Workbooks("Testworkbook.xlsx").Close False
   Application.DisplayAlerts = True
End Sub

again this will work only if all workbooks that you copy from have sheet named EXPORT
Before you start make folder at your "c" drive named TEST

 

[Bill Williamson]

Good Morning AC,

Thank you for your input and your help with this,
I coded the input box's I needed, they seem to be working ok,
I added this Save and transfer code to mine and ran it.
Its getting stuck on this line 'Set wsDest = Workbooks("StainlessDataTest.xlsm").Worksheets("All Data")

Here is the full code

Sub SitelineDataMacro()
'
' Siteline Data Macro
' Shorten Data File from Siteline
'
' Keyboard Shortcut: Ctrl+g
'
Application.ScreenUpdating = False
    Columns("A:B").Select
    Selection.ClearContents
    Selection.Delete Shift:=xlToLeft
    Columns("B:C").Select
    Selection.Delete Shift:=xlToLeft
    Columns("C:AA").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:S").Select
    Selection.Delete Shift:=xlToLeft
    Columns("E:V").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.SmallScroll ToRight:=-3
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("E4").Select
    Columns("B").Select
    Selection.Cut
    Columns("D").Select
    Selection.Insert Shift:=xlToRight
    
'Removes "J" from Job Numbers
    Columns("A").Select
    'Range("A2:A$").Select
    Selection.Replace "j", ""
    Cells.Range("A1").Select
    Selection.Replace "ob", "Job#"
 'Renames Part Number
    Columns("C").Select
    Selection.Replace "item", "Part#"
 'Renames Quantity
    Columns("D").Select
    Selection.Replace "Received", "Quantity"
    
  
 'Delete any Row that Part Number ends in "C"
 
    Dim lr As Long, i As Long
    lr = Range("C" & Rows.Count).End(xlUp).Row
    For i = lr To 1 Step -1
        If InStr(Range("C" & i), "C") > 0 Then
            Range("C" & i).EntireRow.Delete
        End If
    Next i
    ActiveSheet.Columns("A:B").Insert Shift:=xlToRight
    ActiveSheet.Name = "Export"



'Pulls data from workbook name
'  Dim s As String, CSO As String, Customer As String
'  s = ActiveWorkbook.Name
'  Customer = Left(s, InStr(1, s, " ") - 1)
'  CSO = Mid(s, InStr(1, s, " ") + 1, Len(s) - Len(Customer) - 6)

Dim CSO As String, Customer As String
CSO = InputBox("CSO #")
Customer = InputBox("Customer Name")
Range("A2").Value = CSO
Range("B2").Value = Customer


    Range("A1:B1").Value = Array("CSO#", "Customer")
    [A2].Resize(Range("C" & Rows.Count).End(xlUp)(0).Row, 2).Value = Array(CSO, Customer)
    Columns("C").Select
    Selection.Cut
    Columns("B").Select
    Selection.Insert Shift:=xlToRight


'Centers Resizes and Aligns Data to Correct Format
     Cells.Select
    With Selection
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
  

    
    
    
    'ActiveWorkbook.Close savechanges:=True
    
 Application.ScreenUpdating = True
 Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:\Test\Testworkbook.xlsx", FileFormat:=51

'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

  'Set variables for copy and destination sheets
  Set wsCopy = Workbooks("Testworkbook.xlsx").Worksheets("Export")
  Set wsDest = Workbooks("StainlessDataTest.xlsm").Worksheets("All Data")

  ' Find last used row in the copy range based on data in column A
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

  ' Find first blank row in the destination range based on data in column C
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row

  'Copy& Paste Data
  wsCopy.Range("A2:D" & lCopyLastRow).Copy _
    wsDest.Range("C" & lDestLastRow)
   Workbooks("Testworkbook.xlsx").Close False
   Application.DisplayAlerts = True
End Sub

I thought it may have been something to do with my destination file location so I moved a copy of it to The Test Dir as well.

getting a run time error 9

Subscript out of range?



Thanks for your help,


Bill Williamson

 

[Bill Williamson]

I figured out the error, Simple sheet name discrepancy.