Copy/Paste Between Workbooks faster..?

L

Lukums

Board Regular
Joined
Nov 23, 2015
Messages
195
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
 
Last edited:

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
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
 
Upvote 0
HotRhodium said:
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
Click to expand...

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!
 
Upvote 0
Hey mate, no good bombs out on : DownpipeMachineWS.Cells(erow, 1).Paste

Method of object can't be used.


 
Upvote 0
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
 
Upvote 0
Michael M said:
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
Click to expand...

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

didn't
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
:oops:....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
 
Upvote 0
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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
My code is suddenly really slow
Replies
1
Views
125
RobP
R
S
  • Solved
win11 not working win 10 is
Replies
3
Views
159
Joe4
Joe4
C
  • Question
A Bookmark to return to the same row when exiting and opening the application
Replies
8
Views
148
Edgar_
Edgar_
C
  • Question
Copy and paste data through multiple workbooks
Replies
2
Views
173
CDaviess
C
R
  • Solved
VBA used to copy DATA to unopened Workbook
Replies
2
Views
299
Ragarm13
R

Forum statistics

Threads
1,214,426
Messages
6,119,411
Members
448,894
Latest member
spenstar

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top