Solved: use array to speed up copy and paste

[mperrah]

I am trying to speed up a copy and paste process.
currently my sub scans column A for the letter "a"
if present the sub copies some of the values in the row to another sheet.
Would the process go faster if I load the used cells to an array,
and use coordinates to transfer the data? still scanning for the "a" in the first column...

I usually only use 20 rows or so down nd the columns are always 50 accross. I use a worksheet_change and selection change sub on this data, and I think my sub to copy data might be slowing down from selection change. If I can disable a worksheet sub and re-eneable after the transfer is complete may help (don't know how to do this)

this is the sub to transfer the data. Each entry transfer takes over a minute. Screen at bottom says calculating repeatedly...
not sure what is being calculated either?

[VBA]For Each Cell In sh_source.Range("C3:C" & _
sh_source.Range("C" & Rows.Count).End(xlUp).Row)
If Cell.Offset(, -2).Value = "a" Then
With sh_source
.Range("C" & Cell.Row).Copy
sh_dest.Range("C" & sh_dest.Range("C" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("J" & Cell.Row).Copy sh_dest.Range("B" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AU" & Cell.Row).Copy
sh_dest.Range("D" & sh_dest.Range("C" & Rows.Count).End(xlUp).Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("O" & Cell.Row).Copy sh_dest.Range("E" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("E" & Cell.Row).Copy sh_dest.Range("F" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("P" & Cell.Row).Copy sh_dest.Range("G" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("Q" & Cell.Row).Copy sh_dest.Range("H" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("R" & Cell.Row).Copy sh_dest.Range("I" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("S" & Cell.Row).Copy sh_dest.Range("J" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("T" & Cell.Row).Copy sh_dest.Range("K" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("U" & Cell.Row).Copy sh_dest.Range("L" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("V" & Cell.Row).Copy sh_dest.Range("M" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("W" & Cell.Row).Copy sh_dest.Range("N" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("X" & Cell.Row).Copy sh_dest.Range("O" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("Y" & Cell.Row).Copy sh_dest.Range("P" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("Z" & Cell.Row).Copy sh_dest.Range("Q" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AA" & Cell.Row).Copy sh_dest.Range("R" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AB" & Cell.Row).Copy sh_dest.Range("S" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AC" & Cell.Row).Copy sh_dest.Range("T" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AD" & Cell.Row).Copy sh_dest.Range("U" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AE" & Cell.Row).Copy sh_dest.Range("V" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AF" & Cell.Row).Copy sh_dest.Range("W" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AG" & Cell.Row).Copy sh_dest.Range("X" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AH" & Cell.Row).Copy sh_dest.Range("Y" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AI" & Cell.Row).Copy sh_dest.Range("Z" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AJ" & Cell.Row).Copy sh_dest.Range("AA" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AK" & Cell.Row).Copy sh_dest.Range("AB" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AL" & Cell.Row).Copy sh_dest.Range("AC" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AM" & Cell.Row).Copy sh_dest.Range("AD" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AN" & Cell.Row).Copy sh_dest.Range("AE" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AO" & Cell.Row).Copy sh_dest.Range("AF" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AP" & Cell.Row).Copy sh_dest.Range("AG" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AQ" & Cell.Row).Copy sh_dest.Range("AH" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AR" & Cell.Row).Copy sh_dest.Range("AI" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AS" & Cell.Row).Copy sh_dest.Range("AJ" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
.Range("AT" & Cell.Row).Copy sh_dest.Range("AK" _
& sh_dest.Range("C" & Rows.Count).End(xlUp).Row)
End With
End If
Next Cell[/VBA]

I was thinking something like this
[VBA]
sub arrayCopy()
Dim arrayData() as array ' is this right?
dim i as long
dim lastRowD as long
dim lastRowQ as long
dim trgtSht as worksheet

set trgtSht = workheets("QCDetail")
set lastRowQ = trgtSht.range("B" & Rows.Count).End
set lastRow = worksheets("Data").range("C" & Rows.Count).End(xlUp).Row)
redim arrayData(1 to 50) ' as 50 columns accross?
for i = 3 to lastRowD ' data starts in 3rd row down
if i.offset(0, -3) = "a" then ' check column A for "a"
arrayData(10, i).value = trgtSht.range("B" & lastRowQ) 'first value copy to QCDetail
' duplicate process to accomidate each copy item
end if
next i
end sub
[/VBA]
not tested, but am I on the right track?
Would this speed up the above code or is there another way to pick the source data and target location that works more quickly?

I though about formating the data to have the same column locations on both pages. The problem is I use all of the data to print a form and make an archive copy of the form as an added worksheet.
The QCDetail sheet only uses some of the data.
I do have a copy of the full data and a sheet called "Raw"
I could use match and index to make the other forms, or 2 sheets for data.
1 to setup for archive and print, and the other for QCDetail.
My goal is to speed up the process...
I already uploaded the file in a different thread, I'll link it here.
Mark

[mperrah]

the array would use these entries in a wierd order for the first few,
then from 16 to 46 is sequential

column 10 copies to 2
column 3 copies to 3,
 47 to 4,
 15 to 5,
 5 to 6, 
16 to 7,
17 to 8, 
etc...
46 to 37 'last value

could I call the whole row in one line:
[vba]
with arrayData(10,3,47,15,5,16, ....., 46)[/vba]
calling the column values and use a variable for the row placeholder
through each pass of the rows found with "a" in column A?
If the arrayData() counts for just column values in one row.
Or can I store row and column in the array and call the columns explicitly and the rows variably (is that a word?) using a variable...

I have this to remove several columns at a time, can i translate to copying...
[VBA]Range("A:A,D:E,G:G,H:H,J:J,O:O,T:AR,AT:BA,BC:IV").EntireColumn.Delete[/VBA]

[Bob Phillips]

See if this is quicker

[vba]

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
NextRow = sh_dest.Range("C" & Rows.Count).End(xlUp).Row
For Each cell In sh_source.Range("C3:C" & NextRow)
If cell.Offset(, -2).Value = "a" Then
With sh_source
.Range("C" & cell.Row).Copy
sh_dest.Range("C" & NextRow + 1).PasteSpecial Paste:=xlPasteValues
.Range("J" & cell.Row).Copy sh_dest.Range("B" & NextRow)
.Range("AU" & cell.Row).Copy
sh_dest.Range("D" & NextRow).PasteSpecial Paste:=xlPasteValues
.Range("O" & cell.Row).Copy sh_dest.Range("E" & NextRow)
.Range("E" & cell.Row).Copy sh_dest.Range("F" & NextRow)
.Range("P" & cell.Row).Resize(, 31).Copy sh_dest.Range("G" & NextRow)
End With
End If
Next cell
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
[/vba]

[mperrah]

Thank You xld!
At first your code was copying everything to one line.
I had that same problem early in development so found a slight modification.
The lastrow is different from the source and the destination...

But man is that fast.
You don't know how many lives you just touched.
I feel all giddy.
Mark

modified solution... note the tribute in the sub name...
[VBA]
Sub AddToDetail_xld()
Dim sh_source As Worksheet
Dim sh_dest As Worksheet
Dim Cell As Range

Set sh_source = Worksheets("Data")
Set sh_dest = Worksheets("QCDetail")

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Call remove_borders

nextRowD = sh_dest.Range("C" & Rows.Count).End(xlUp).Row
NextRowS = sh_source.Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In sh_source.Range("C3:C" & NextRowS)
If Cell.Offset(, -2).Value = "a" Then
nextRowD = nextRowD + 1
With sh_source
.Range("C" & Cell.Row).Copy
sh_dest.Range("C" & nextRowD).PasteSpecial Paste:=xlPasteValues
.Range("J" & Cell.Row).Copy sh_dest.Range("B" & nextRowD)
.Range("AU" & Cell.Row).Copy
sh_dest.Range("D" & nextRowD).PasteSpecial Paste:=xlPasteValues
.Range("O" & Cell.Row).Copy sh_dest.Range("E" & nextRowD)
.Range("E" & Cell.Row).Copy sh_dest.Range("F" & nextRowD)
.Range("P" & Cell.Row).Resize(, 31).Copy sh_dest.Range("G" & nextRowD)
End With
End If
Next Cell

Sheets("Summary").Select
Call sortTechs

Call addbordertolastrowB
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
[/VBA]

[mperrah]

what kind of jedi mind trick do you have for this:
[VBA]Sub sortTechs()

' clear the old Summary range
Range(Sheets("Summary").Range("B2:C2"), _
Sheets("Summary").Range("B2:C2").End(xlDown)).ClearContents

' copy current range from Library
Range(Sheets("library").Range("AT2:AU2"), _
Sheets("library").Range("AT2:AU2").End(xlDown)).Copy _
Sheets("Summary").Range("B2")

' replace formula with values
Range(Sheets("Summary").Range("B2:C2"), _
Sheets("Summary").Range("B2:C2").End(xlDown)).Value = _
Range(Sheets("Summary").Range("B2:C2"), _
Sheets("Summary").Range("B2:C2").End(xlDown)).Value

Sheets("Summary").Range("B2:C2").End(xlDown).Select ' error here
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Call FixSummary
Call AddSummaryFormula

End Sub[/VBA]

It errors after our update saying select method of range class failed

here too:
[VBA]
Sub addbordertolastrowB()

Dim LastRowB As Long

With Worksheets("QCDetail") ' .Range("$B:$B")
LastRowB = .cells(.Rows.Count, 1).End(xlUp).Row

Worksheets("QCDetail").Range("B" & LastRowB & ":AK" & LastRowB).Select

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Range("B" & LastRowB).Select
End With
End Sub
[/VBA]
If I click on the page and hit play in the vbe the code finishes fine.
I was trying to avoid sheet select or activate if it slows down the process. but of it has to be there, your help has already made it very zippy

[Bob Phillips]

Be very careful that everything is properly qualified and no selecting

[vba]

Sub sortTechs()

With Sheets("Summary")
' clear the old Summary range
.Range(.Range("B2:C2"), .Range("B2:C2").End(xlDown)).ClearContents

' copy current range from Library
Sheets("library").Range(Sheets("library").Range("AT2:AU2"), _
Sheets("library").Range("AT2:AU2").End(xlDown)).Copy .Range("B2")

' replace formula with values
.Range(.Range("B2:C2"), .Range("B2:C2").End(xlDown)).Value = _
.Range(.Range("B2:C2"), .Range("B2:C2").End(xlDown)).Value

.Range("B2:C2").End(xlDown).Sort Key1:=.Range("C1"), _
Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With

Call FixSummary
Call AddSummaryFormula

End Sub
[/vba]

[mperrah]

Outstanding!
Thank you so much.
Mark