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
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: