Copy/Paste Between Workbooks faster..?

[Lukums]

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>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</sub>

 

[Lukums]

Hey Michael M,

Working as intended however it's not finding last black row in the DownpipeMachineWS and ultimately not completing the paste.

I did change this sightly to get it work but I did those bad habits previously posted any ideas?

 

[Michael M]

sorry, what do you mean by

it's not finding last black row

 

[Lukums]

Omg sorry Michael.

Blank Row

then executes the paste

 

[Michael M]

Hmmm...still UNTESTED
I've changed the code to OPEN the other file first...I think the copy then open is causing the issue

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

 

[Lukums]

Hey Michael,

I think the he done it!

HOWEVER one final issue row 1 is being copied as it's a head/banner I need the copy to effectively start on row 2 not 1.

Apart from this AMAZING THANK YOU!

 

[Lukums]

Hey Michael,

So that 1 row needs to be stricken from the copy as the data situated starts on row 2.

However there was another change which I cant work out because honestly I don't understand the code:

The row copy stops at H column but I need it to stop at Y Column how do I change this.

I thought the copy was coming from the 8:MB but I don't think it is.

 

[Michael M]

This should get rid of the header row...but I dont understand your other statement

The row copy stops at H column but I need it to stop at Y Column

the code copies the entire row....unless of course you have blank columns between cols H and W

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

 

[Lukums]

Hello Michael,

Worked a treat.

You're correct again sir.

I have a break between h:y as these are hidden cells

It copies fine to H but I need V,W,X,Y also... gosh im difficult.

SOrry thanks for all your help

 

[Michael M]

Try this

Sub ImportBlueDownpipe()
Dim DownpipeMachineWS As Worksheet
Set TB = ActiveWorkbook
Workbooks.Open "C:\Temp\Best Shed Scheduler.xlsm" '''''Found on local machine drive'''''nothing networked''''
Set OB = ActiveWorkbook
erow = OB.Sheets("Downpipe Machine").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
TB.Activate
Sheets("Downpipe").Range("H:Y").EntireColumn.Hidden = False
 With Sheets("Downpipe").UsedRange
            .AutoFilter
            .AutoFilter field:=8, Criteria1:="MB"
            .AutoFilter field:=23, Criteria1:="Downpipe"
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy OB.Sheets("Downpipe Machine").Cells(erow, 1)
            .AutoFilter
    End With
Sheets("Downpipe").Range("H:Y").EntireColumn.Hidden = True
OB.Save
OB.Close
End Sub

 

[Lukums]

Hello Michael,

Ok so it worked copied all the data perfectly apart from one thing. It destroyed my macro buttons which I have in row 1 ( deleted them it looks like )

It also compacted all rows between H:BJ ( hidden all those rows ) after macro ran.

My sheet looks like A:H ( gap ) then V:Y ( gap ) then continues into BJ.

But super close now!