Macro copy data to not open workbook

[ste33uka]

I use the following macro to copy data from an open workbook to a workbook called "stored", sheet "data" if D1 value is "yes"
Is it possible to copy data without workbook "stored" being open ?

Sub copy_to_dataworkbook()
   Dim i As Long
   For i = 1 To 60
      With Sheets(CStr(i))
         If LCase(.Range("D1").Value) = "yes" Then
          .Range("Vs86:WH105").Copy
            Workbooks("stored").Sheets("data").Range("cu" & Rows.Count).End(xlUp).Offset(2).PasteSpecial xlPasteValues
         End If
      End With
   Next i
End Sub

 

[NdNoviceHlp]

No but U can open the wb, put stuff in it and close it in the background without even knowing that it was open... sort of the same. HTH. Dave

 

[ste33uka]

No but U can open the wb, put stuff in it and close it in the background without even knowing that it was open... sort of the same. HTH. Dave

Would you have a macro code for that ?

 

[NdNoviceHlp]

Do you have the full file path for the "stored" workbook? Dave

 

[ste33uka]

Do you have the full file path for the "stored" workbook? Dave

C:\Users\home\Desktop\stored

 

[NdNoviceHlp]

Untested code. Please make a back up of your file before you test the code. Dave

Sub copy_to_dataworkbook()
Dim i As Long, FSO As Object, FilDir As Object
On Error GoTo QuitThis
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set FSO = CreateObject("scripting.filesystemobject")
'***change File path to your file
Set FilDir = FSO.getfile("C:\Users\home\Desktop\stored.xlsm")
Workbooks.Open Filename:=FilDir
   For i = 1 To 60
      With ThisWorkbook.Sheets(CStr(i))
         If LCase(.Range("D1").Value) = "yes" Then
          .Range("Vs86:WH105").Copy
            Workbooks(FilDir.Name).Sheets("data").Range("cu" & Rows.Count) _
                    .End(xlUp).Offset(2).PasteSpecial xlPasteValues
         Application.CutCopyMode = False
         End If
      End With
   Next i
Workbooks(FilDir.Name).Close SaveChanges:=True
QuitThis:
Set FSO = Nothing
Set FilDir = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

edit: changed save to true

 

[mohadin]

Hi
What about

Sub copy_to_dataworkbook()
   Dim i As Long
   Dim wb
   Set wb = Workbooks.Open("C:\Users\home\Desktop\stored.xlsx")
   For i = 1 To 60
      With Sheets(CStr(i))
         If LCase(.Range("D1").Value) = "yes" Then
          .Range("Vs86:WH105").Copy
            wb.Sheets("data").Range("cu" & Rows.Count).End(xlUp).Offset(2).PasteSpecial xlPasteValues
         End If
      End With
   Next i
   wb.Close False
End Sub

 

[NdNoviceHlp]

Missed the edit timer. Added some error msg along with the save change.

Sub copy_to_dataworkbook()
Dim i As Long, FSO As Object, FilDir As Object
On Error GoTo QuitThis
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set FSO = CreateObject("scripting.filesystemobject")
'***change File path to your file
Set FilDir = FSO.getfile("C:\Users\home\Desktop\stored.xlsm")
Workbooks.Open Filename:=FilDir
   For i = 1 To 60
      With ThisWorkbook.Sheets(CStr(i))
         If LCase(.Range("D1").Value) = "yes" Then
          .Range("Vs86:WH105").Copy
            Workbooks(FilDir.Name).Sheets("data").Range("cu" & Rows.Count) _
                    .End(xlUp).Offset(2).PasteSpecial xlPasteValues
         Application.CutCopyMode = True
         End If
      End With
   Next i
Workbooks(FilDir.Name).Close SaveChanges:=True
QuitThis:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Error"
End If
Set FSO = Nothing
Set FilDir = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Dave

 

[ste33uka]

Untested code. Please make a back up of your file before you test the code. Dave

Sub copy_to_dataworkbook()
Dim i As Long, FSO As Object, FilDir As Object
On Error GoTo QuitThis
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set FSO = CreateObject("scripting.filesystemobject")
'***change File path to your file
Set FilDir = FSO.getfile("C:\Users\home\Desktop\stored.xlsm")
Workbooks.Open Filename:=FilDir
   For i = 1 To 60
      With ThisWorkbook.Sheets(CStr(i))
         If LCase(.Range("D1").Value) = "yes" Then
          .Range("Vs86:WH105").Copy
            Workbooks(FilDir.Name).Sheets("data").Range("cu" & Rows.Count) _
                    .End(xlUp).Offset(2).PasteSpecial xlPasteValues
         Application.CutCopyMode = False
         End If
      End With
   Next i
Workbooks(FilDir.Name).Close SaveChanges:=True
QuitThis:
Set FSO = Nothing
Set FilDir = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

edit: changed save to true

Thanks alot for your help on that, that worked , job done

 

[NdNoviceHlp]

You are welcome. Please see my last post that includes some error code for you. Dave