Copy/Paste Between Workbooks faster..?

**Lukums** · Mar 30th, 2017, 07:10 PM

Hey guys,

Need some desperate help with this one the code works fine but it's just sooooo **** slow... "probably my fault"

Any advise? Needs to be a hell of a lot quicker for what I'm trying to achieve.

_{Sub ImportBlueDownpipe()

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To LastRow

Sheets("Downpipe").Select

If Range("H" & i).Value = "MB" And Range("W" & i).Value = "Downpipe" Then

Rows(i).Select

Selection.Copy

Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''

Dim p As Integer, q As Integer

p = Worksheets.Count

For q = 1 To p

Next q

Sheets("Downpipe Machine").Select

erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ActiveSheet.Cells(erow, 1).Select

ActiveSheet.Paste

ActiveWorkbook.Save

ActiveWorkbook.Close

Application.CutCopyMode = False

End If

Next i

End Sub}

**HotRhodium** · Mar 30th, 2017, 07:27 PM

Yeah you have a lot to gain by not selecting and activating everything. Could you check the code below for intent?

Code:

Sub ImportBlueDownpipe()
Dim DownpipeWS As Worksheet, DownpipeMachineWS As Worksheet
 Set DownpipeWS = Sheets("Downpipe")
 LastRow = DownpipeWS.Range("A" & DownpipeWS.Rows.Count).End(xlUp).Row

  For i = 1 To LastRow
 
   If DownpipeWS.Range("H" & i).Value = "MB" And DownpipeWS.Range("W" & i).Value = "Downpipe" Then
   DownpipeWS.Rows(i).Copy
  
   Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
  
   Dim p As Integer, q As Integer
  
   p = Worksheets.Count
  
'    For q = 1 To p ''I have no idea what this does is for something later?
'
'    Next q
  
   Set DownpipeMachineWS = Sheets("Downpipe Machine")
  
   erow = DownpipeMachineWS.Cells(DownpipeMachineWS.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  
   DownpipeMachineWS.Cells(erow, 1).Paste
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   Application.CutCopyMode = False
  
   End If
 
  Next i

 End Sub

**Lukums** · Mar 30th, 2017, 07:50 PM

Originally Posted by HotRhodium

Yeah you have a lot to gain by not selecting and activating everything. Could you check the code below for intent?

Code:

Sub ImportBlueDownpipe()
Dim DownpipeWS As Worksheet, DownpipeMachineWS As Worksheet
 Set DownpipeWS = Sheets("Downpipe")
 LastRow = DownpipeWS.Range("A" & DownpipeWS.Rows.Count).End(xlUp).Row

  For i = 1 To LastRow
 
   If DownpipeWS.Range("H" & i).Value = "MB" And DownpipeWS.Range("W" & i).Value = "Downpipe" Then
   DownpipeWS.Rows(i).Copy
  
   Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
  
   Dim p As Integer, q As Integer
  
   p = Worksheets.Count
  
'    For q = 1 To p ''I have no idea what this does is for something later?
'
'    Next q
  
   Set DownpipeMachineWS = Sheets("Downpipe Machine")
  
   erow = DownpipeMachineWS.Cells(DownpipeMachineWS.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  
   DownpipeMachineWS.Cells(erow, 1).Paste
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   Application.CutCopyMode = False
  
   End If
 
  Next i

 End Sub

I see what you've done there, and yes that code is for something later on but I'll try execute what you've suggest and report back!

**Lukums** · Mar 30th, 2017, 08:13 PM

Hey mate, no good bombs out on : DownpipeMachineWS.Cells(erow, 1).Paste

Method of object can't be used.

**Michael M** · Mar 30th, 2017, 08:14 PM

dont have Excel at the moment .....but consider using auto filter to get the visible cells in the downpipe sheet then copy across in one block..
This is UNTESTED

Code:

Sub ImportBlueDownpipe()
Dim DownpipeWS As Worksheet, DownpipeMachineWS As Worksheet
 Set DownpipeWS = Sheets("Downpipe")
 With ActiveSheet
            .AutoFilterMode = False
            .UsedRange.AutoFilter
            .UsedRange.AutoFilter field:=8, Criteria1:="MB"
            .UsedRange.AutoFilter field:=23, Criteria1:="Downpipe"
            .SpecialCells(xlCellTypeVisible).Copy
            .AutoFilter
    End With
  
   Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
  
   Set DownpipeMachineWS = Sheets("Downpipe Machine")
  
   erow = DownpipeMachineWS.Cells(DownpipeMachineWS.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  
   DownpipeMachineWS.Cells(erow, 1).Paste
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   Application.CutCopyMode = False
  
   End If

End Sub

**Lukums** · Mar 30th, 2017, 08:22 PM

Originally Posted by Michael M

dont have Excel at the moment .....but consider using auto filter to get the visible cells in the downpipe sheet then copy across in one block..
This is UNTESTED

Code:

Sub ImportBlueDownpipe()
Dim DownpipeWS As Worksheet, DownpipeMachineWS As Worksheet
 Set DownpipeWS = Sheets("Downpipe")
 With ActiveSheet
            .AutoFilterMode = False
            .UsedRange.AutoFilter
            .UsedRange.AutoFilter field:=8, Criteria1:="MB"
            .UsedRange.AutoFilter field:=23, Criteria1:="Downpipe"
            .SpecialCells(xlCellTypeVisible).Copy
            .AutoFilter
    End With
  
   Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
  
   Set DownpipeMachineWS = Sheets("Downpipe Machine")
  
   erow = DownpipeMachineWS.Cells(DownpipeMachineWS.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  
   DownpipeMachineWS.Cells(erow, 1).Paste
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   Application.CutCopyMode = False
  
   End If

End Sub

I didn't know such things were possible... I'll look into it. THANKS

didn't

**Lukums** · Mar 30th, 2017, 08:28 PM

Hello Michael M

That was bloody amazing to see it's exactly what I'm looking for!!!

However, it bombs at .SpecialCells(x1CellTypeVisible).Copy

Object osnt support this property or method RUn time error 438

Any ideas?

**HotRhodium** · Mar 30th, 2017, 08:29 PM

Ok I see this should paste. What data exactly are you wanting to paste? It will move much faster if you paste values only fyi.

Code:

Sub ImportBlueDownpipe()
Dim DownpipeWS As Worksheet, DownpipeMachineWS As Worksheet

 LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
  Set DownpipeWS = Sheets("Downpipe")

  For i = 1 To LastRow
 
   If DownpipeWS.Range("H" & i).Value = "MB" And DownpipeWS.Range("W" & i).Value = "Downpipe" Then
   DownpipeWS.Rows(i).Copy
  
   Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
  
   Dim p As Integer, q As Integer
  
   p = Worksheets.Count
  
'    For q = 1 To p ''I have no idea what this does is for something later?
'
'    Next q
  
   Set DownpipeMachineWS = Sheets("Downpipe Machine")
  
   erow = DownpipeMachineWS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  
   DownpipeMachineWS.Cells(erow, 1).PasteSpecial xlPasteAll
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   Application.CutCopyMode = False
  
   End If
 
  Next i

 End Sub

**Michael M** · Mar 30th, 2017, 09:15 PM

....missed a line

Code:

Sub ImportBlueDownpipe()
Dim DownpipeWS As Worksheet, DownpipeMachineWS As Worksheet
 Set DownpipeWS = Sheets("Downpipe")
 With ActiveSheet
            .AutoFilterMode = False
            .UsedRange.AutoFilter
            .UsedRange.AutoFilter field:=8, Criteria1:="MB"
            .UsedRange.AutoFilter field:=23, Criteria1:="Downpipe"
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy
            .AutoFilter
    End With
  
   Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
  
   Set DownpipeMachineWS = Sheets("Downpipe Machine")
  
   erow = DownpipeMachineWS.Cells(DownpipeMachineWS.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
  
   DownpipeMachineWS.Cells(erow, 1).Paste
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   Application.CutCopyMode = False
  
   

End Sub

**Michael M** · Mar 30th, 2017, 09:25 PM

A bit cleaner....but still UNTESTED

Code:

Sub ImportBlueDownpipe()
Dim DownpipeMachineWS As Worksheet
 With Sheets("Downpipe").UsedRange
            .AutoFilter
            .AutoFilter field:=8, Criteria1:="MB"
            .AutoFilter field:=23, Criteria1:="Downpipe"
            .SpecialCells(xlCellTypeVisible).Copy
            .AutoFilter
    End With
   Workbooks.Open Filename:="B:\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
   Set DownpipeMachineWS = Sheets("Downpipe Machine")
   erow = DownpipeMachineWS.Cells(DownpipeMachineWS.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
   DownpipeMachineWS.Cells(erow, 1).Paste
   ActiveWorkbook.Save
   ActiveWorkbook.Close
   Application.CutCopyMode = False
End Sub