speeding up code that is super slow

The code below is part of a much larger spreadsheet that I wrote using help from this site, since I have 0 prior experience. I know it is full of useless, slow, code, but until I can get someone to rewrite it completely, it's all I have to work with.

My problem is that the code below is extremely slow to process. Basically, it grabs info from another sheet that has a possibility of having 500 lines of part numbers. There are never that many on one order, more like 40-50, but I don't know how to copy just the used cells, so I copy all visible cells in the 500 line range, after it has been autofiltered. I then paste that entire range. There are a lot of merged cells that contain data on the original sheet, but are not used on this one, so I do a lot of unmerging and merging (which I think is what's taking up all the time)

If someone can look at this and give me some pointers as to how I can speed up this process, I would appreciate it greatly. Right now, it takes about 30 seconds or so to run.

Thanks in advance for ALL of the help thus far and in the future, I'm sure.

Private Sub CommandButton1_Click()

'populate top of traffic sheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet

Set ws1 = Sheets("Cover Sheet")
Set ws2 = Sheets("Quote")
Set ws3 = Sheets("Order Form")
Set ws4 = Sheets("Traffic")

'opportunity name
ws2.Range("C6").Copy Destination:=ws4.Range("B3")
'original order date
ws3.Range("G4").Copy Destination:=ws4.Range("C3")
'insert vendor initials onto traffic sheet
Dim a As String
a = ws2.Range("G12")
a = Left(a, 2)
ws4.Range("D3") = a
'insert rep
ws2.Range("C11").Copy Destination:=ws4.Range("E3")
'received

'# parts
ws2.Range("A503").Copy Destination:=ws4.Range("H3")
'Drop
ws1.Range("C48").Copy Destination:=ws4.Range("I3")
'P/U
ws1.Range("C49").Copy Destination:=ws4.Range("J3")
'Flat
ws1.Range("C50").Copy Destination:=ws4.Range("K3")
'Assembly
ws1.Range("C51").Copy Destination:=ws4.Range("L3")
'Mods
ws1.Range("C52").Copy Destination:=ws4.Range("K3")
'Delivery
ws1.Range("C53").Copy Destination:=ws4.Range("O3")
'Installation
ws1.Range("C54").Copy Destination:=ws4.Range("Q3")

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'create traffic sheet

ws2.Range("A6:F10").Copy Destination:=ws4.Range("A4:F8")
ws2.Range("G13").Copy Destination:=ws4.Range("G8")
ws2.Activate
ActiveSheet.Unprotect
ws4.Range("C9:G500").UnMerge
ws2.Range("A14:B500").Copy Destination:=ws4.Range("A9")
ws2.Range("E14:F500").Copy Destination:=ws4.Range("C9")
ws4.Range("H6:J8").Merge
ws4.Range("H6") = ws4.Range("D3")

ws4.Range("B9").Value = "PARTS"
ws4.Range("A9") = ws4.Range("H3").Font.Size = 26

'merge C - G
For i = 9 To 500
Application.DisplayAlerts = False
ws4.Range("C" & i & ":G" & i).MergeCells = True
Next i
'unmerge bottom of sheet
ws4.Range("C57:G58").UnMerge
Application.DisplayAlerts = True

'populate bottom of sheet
ws4.Range("A57:H58").HorizontalAlignment = xlCenter

'cell outlines
ws4.Range("A57:J58").Borders(xlEdgeLeft).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlEdgeRight).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlEdgeBottom).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlEdgeTop).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlInsideVertical).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlInsideHorizontal).LineStyle = xlContinuous
ws4.Range("A9:J9").Borders(xlEdgeTop).LineStyle = xlContinuous
ws4.Range("A4:J4").Borders(xlEdgeTop).LineStyle = xlContinuous
ws4.Range("A4:A8").Borders(xlEdgeLeft).LineStyle = xlContinuous
ws4.Range("J6:J8").Borders(xlEdgeRight).LineStyle = xlContinuous
ws4.Range("A9:J9").Borders(xlEdgeBottom).LineStyle = xlContinuous

'bottom of page population
ws4.Range("A57").Value = "DROP"
ws4.Range("A58") = ws4.Range("I3")
ws4.Range("B57").Value = "PICK UP"
ws4.Range("B58") = ws4.Range("J3")
ws4.Range("C57").Value = "FLAT"
ws4.Range("C58") = ws4.Range("K3")
ws4.Range("D57").Value = "ASSY"
ws4.Range("D58") = ws4.Range("L3")
ws4.Range("E57:F57").MergeCells = True
ws4.Range("E58:F58").MergeCells = True
ws4.Range("E57").Value = "DELIVERY"
ws4.Range("E58") = ws4.Range("O3")
ws4.Range("G57").Value = "MODIFICATIONS"
ws4.Range("G58") = ws4.Range("N3")
ws4.Range("H57:J57").MergeCells = True
ws4.Range("H58:J58").MergeCells = True
ws4.Range("H57").Value = "INSTALLATION"
ws4.Range("H58") = ws4.Range("Q3")


'print to traffic printer
Application.ActivePrinter = "\\traffic\Traffic on Ne11:"

    ws4.PageSetup.PrintArea = "$A$4:$J$58"
    ws4.PrintOut Copies:=1






Application.ScreenUpdating = False
 'Traffic - My Computer
    Sheets("Traffic").Select
    Sheets("traffic").Range("A3:Y3").Select
    Selection.Copy
    Windows("traffic.xlsm").Activate
    Sheets("traffic").Range("A65536:Y65536").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    
    ActiveWorkbook.Save
    'ActiveWindow.Close


End Sub

Basically, you want to elminate all the copy and pastes and merging of cells. To get rid of a copy and paste, just set a cell equal to where you were going to paste from. Getting rid of the merged cells is going to be up to you. Usually you can change the row height to fit extra text in the height, and for extra width you can format as Center Across Selection. Try this, it won't run a ton faster until you get rid of all that cell merging, but it may help a little.:

Private Sub CommandButton1_Click()

'populate top of traffic sheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim intRow As Integer

Set ws1 = Sheets("Cover Sheet")
Set ws2 = Sheets("Quote")
Set ws3 = Sheets("Order Form")
Set ws4 = Sheets("Traffic")

'opportunity name
ws4.Cells(3, "B").Value = ws2.Cells(6, "C").Value
'original order date
ws4.Cells(3, "C").Value = ws3.Cells(4, "G").Value
'insert vendor initials onto traffic sheet
ws4.Cells(3, "D").Value = Left(ws2.Cells(12, "G").Value, 2)
'insert rep
ws4.Cells(3, "E").Value = ws2.Cells(11, "C").Value
'received
'# parts
ws4.Cells(3, "H").Value = ws2.Cells(503, "A").Value
'Drop
ws4.Cells(3, "I").Value = ws1.Cells(48, "C").Value
'P/U
ws4.Cells(3, "J").Value = ws1.Cells(49, "C").Value
'Flat
ws4.Cells(3, "K").Value = ws1.Cells(50, "C").Value
'Assembly
ws4.Cells(3, "L").Value = ws1.Cells(51, "C").Value
'Mods
ws4.Cells(3, "K").Value = ws1.Cells(52, "C").Value 'Should this really go to column K again???
'Delivery
ws4.Cells(3, "O").Value = ws1.Cells(53, "C").Value
'Installation
ws4.Cells(3, "Q").Value = ws1.Cells(54, "C").Value

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'create traffic sheet

ws4.Range("A4:F8") = ws2.Range("A6:F10")
ws4.Range("G8") = ws2.Range("G13")
ws2.Unprotect
ws4.Range("C9:G500").UnMerge
ws2.Range("A14:B500").Copy Destination:=ws4.Range("A9")
ws2.Range("E14:F500").Copy Destination:=ws4.Range("C9")
ws4.Range("H6:J8").Merge
ws4.Range("H6") = ws4.Range("D3")

ws4.Range("B9").Value = "PARTS"
ws4.Range("A9") = ws4.Range("H3").Font.Size = 26

'merge C - G
For i = 9 To 500
Application.DisplayAlerts = False
ws4.Range("C" & i & ":G" & i).MergeCells = True
Next i
'unmerge bottom of sheet
ws4.Range("C57:G58").UnMerge
Application.DisplayAlerts = True

'populate bottom of sheet
ws4.Range("A57:H58").HorizontalAlignment = xlCenter

'cell outlines
ws4.Range("A57:J58").Borders(xlEdgeLeft).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlEdgeRight).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlEdgeBottom).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlEdgeTop).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlInsideVertical).LineStyle = xlContinuous
ws4.Range("A57:J58").Borders(xlInsideHorizontal).LineStyle = xlContinuous
ws4.Range("A9:J9").Borders(xlEdgeTop).LineStyle = xlContinuous
ws4.Range("A4:J4").Borders(xlEdgeTop).LineStyle = xlContinuous
ws4.Range("A4:A8").Borders(xlEdgeLeft).LineStyle = xlContinuous
ws4.Range("J6:J8").Borders(xlEdgeRight).LineStyle = xlContinuous
ws4.Range("A9:J9").Borders(xlEdgeBottom).LineStyle = xlContinuous

'bottom of page population
ws4.Range("A57").Value = "DROP"
ws4.Range("A58") = ws4.Range("I3")
ws4.Range("B57").Value = "PICK UP"
ws4.Range("B58") = ws4.Range("J3")
ws4.Range("C57").Value = "FLAT"
ws4.Range("C58") = ws4.Range("K3")
ws4.Range("D57").Value = "ASSY"
ws4.Range("D58") = ws4.Range("L3")
ws4.Range("E57:F57").MergeCells = True
ws4.Range("E58:F58").MergeCells = True
ws4.Range("E57").Value = "DELIVERY"
ws4.Range("E58") = ws4.Range("O3")
ws4.Range("G57").Value = "MODIFICATIONS"
ws4.Range("G58") = ws4.Range("N3")
ws4.Range("H57:J57").MergeCells = True
ws4.Range("H58:J58").MergeCells = True
ws4.Range("H57").Value = "INSTALLATION"
ws4.Range("H58") = ws4.Range("Q3")


'print to traffic printer
Application.ActivePrinter = "\\traffic\Traffic on Ne11:"

    ws4.PageSetup.PrintArea = "$A$4:$J$58"
    ws4.PrintOut Copies:=1

Application.ScreenUpdating = False
 'Traffic - My Computer
    intRow = Workbooks("traffic.xlsm").Sheets("traffic").Range("A65536").End(xlUp).Row + 1
    Sheets("Traffic").Range("A3:Y3").Copy Destination:=Workbooks("traffic.xlsm").Sheets("traffic").Range("A" & intRow & ":Y" & intRow)
    
    ActiveWorkbook.Save
    'ActiveWindow.Close


End Sub

If you really want to improve this, move it to Access.

this copy technique might be a little faster:

ws4.Range("B3") = ws2.Range("C6")           'opportunity name
ws4.Range("C3") = ws3.Range("G4")           'original order date
ws4.Range("D3") = Left(ws2.Range("G12"), 2) 'insert vendor initials
ws4.Range("E3") = ws2.Range("C11")          'insert rep
                                            'received
ws4.Range("H3") = ws2.Range("A503")         '# parts
ws4.Range("I3") = ws1.Range("C48")          'Drop
ws4.Range("J3") = ws1.Range("C49")          'P/U
ws4.Range("K3") = ws1.Range("C50")          'Flat
ws4.Range("L3") = ws1.Range("C51")          'Assembly
ws4.Range("K3") = ws1.Range("C52")          'Mods
ws4.Range("O3") = ws1.Range("C53")          'Delivery
ws4.Range("Q3") = ws1.Range("C54")          'Installation

All the merge and unmerge stuff later is going to be slow.

You could move this to the top of your macro, before all the copying starts:

Application.ScreenUpdating = False

Then turn it back on again as the last command before you end the macro:

Application.ScreenUpdating = True
End Sub

I think is all you need for a grid pattern:

'cell outlines
ws4.Range("A57:J58").Borders.Weight = xlThin

Copies it or moves it?

Actually, JBeaucaire, I found your code on a different site that I adapted for my use. Works great. Thanks again for all your help.

One last request for this though... Can you tell me how to add the date to the appropriate row in column X on the "Completed" Sheet so when the script is run, it puts todays date at the end of the rows that were moved over on the "completed" sheet?

Private Sub CommandButton1_Click()


'Sub ArchiveInactive()
'JBeaucaire     (2/3/2010)
'Move "inactive" clients to another worksheet
Dim LR As Long, NR As Long, wsI As Worksheet

Set wsI = Sheets("Completed")              'TARGET sheet
    
If ActiveSheet.Name = wsI.Name Then     'make sure the SOURCE sheet is active
    MsgBox "Start macro from data sheet"
    Exit Sub
End If

NR = wsI.Range("A" & Rows.Count).End(xlUp).Row + 1
If NR = 2 Then Rows("1:1").Copy wsI.Range("A1") 'add titles if needed

Columns("W:W").AutoFilter
Columns("W:W").AutoFilter Field:=1, Criteria1:="yes"

LR = Range("W" & Rows.Count).End(xlUp).Row
If LR > 1 Then      'verify there is data to transfer, then do it
    Range("A2:W" & LR).SpecialCells(xlCellTypeVisible).Copy wsI.Range("A" & NR)
    Range("A2:W" & LR).SpecialCells(xlCellTypeVisible).Delete xlShiftUp
End If

ActiveSheet.AutoFilterMode = False
End Sub

Did you know ?

with ws4
  .Range("A57:J58,A9:J9,A4:J4").Borders.LineStyle = xlContinuous
  .Range("A4:A8").Borders(xlEdgeLeft).LineStyle = xlContinuous
  .Range("J6:J8").Borders(xlEdgeRight).LineStyle = xlContinuous
 
  .Range("A57:H57") = split("DROP|PICK UP|FLAT|ASSY|DELIVERY||MODIFICATIONS|INSTALLATION|","|")
  .RANGE("a58:h58")=ARRAY(.[I3],.[J3],.K3],.[L3],"",.[O3],.[N3],[Q3])
End With

But maybe its better to design a formatted master sheet that can be copied every time you need a new sheet based on this format. You better not use VBA for designing/formatting.

Can you switch to Access? You are trying to use Excel like a database, which it was not designed for. You may find technical ways of getting around it, but it would be much easier, faster, and safer to use an application designed for multiple users to work with the same information at the same time.

Do not despair prematurely:
Let's start without removing anything.

Private Sub CommandButton1_Click()
  with sheets("traffic").range([A1],sheets("traffic").usedrange)
    .autofilter 23, "yes"
    y=sheets("Completed").cells(rows.count,1).end(xlup).offset(1).row
    .offset(1).copy sheets("Completed").cells(y,1)
    sheets("completed").cells(y,24).resize(sheets("Completed").cells(rows.count,1).end(xlup).row-y)=format(date,"yyyymmdd")
    .autofilter
  end with
End Sub

Dim your variable at the top of the macro as the correct variable type, proper basic programming:

Option Explicit

Private Sub CommandButton1_Click()
Dim y As Long
'etc....

Or simply remove 'option Explicit' from the module.

This line of code is looking at column A on the "completed" sheet to spot the "last row" of current data and note the "next row" for the target later:

NR = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row + 1

I added another sheet reference into that, underlined above, try that first.

If column A is a bad column to use for that test, then change that to the correct column to check, column B or column W, whatever, then try again.

I have no comment on your shared workbook issue, overcoming network security is often no small feat. Perhaps a new thread to specifically address that question without the need for the full macro as it's not really related to that.

Never remove the Option Explicit from a module until you consider yourself an experienced programmer and can read VBA code as easily as you read this forum.

Yes, removing it solves the current error message problem, and does so by turning OFF your code-checker built into Excel. When you make other simple coding mistakes in the future, which you will do, you will spend a LOT more time trying to find them without Option Explicit. With Option Explicit on, Excel will point out a majority of your syntax errors.

The problem you have is you (?) forgot to declare your variables as the correct variable types. Declaring them is the correct solution.

You might add this near the top of your macro, it is designed to suppress most alert messages and select the default answer, I can't test if this will work to suppress this particular message:

Application.DisplayAlerts = False

BTW, why did you quote my message into your post above? Did I miss something?

What date stamp?

Try this:

If LR > 1 Then      'verify there is data to transfer, then do it
    Range("A2:W" & LR).SpecialCells(xlCellTypeVisible).Copy wsI.Range("A" & NR)
    Range("A2:W" & LR).SpecialCells(xlCellTypeVisible).Delete xlShiftUp
    
    LR = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row
    wsI.Range("X" & NR, wsI.Range("X" & LR)) = Date
End If

PERFECT! Thank you very much for all of your help guys. Awesome experience and will definitely help us tremendously.

Great Job!

Now, if I could only figure out how to mark this threat SOLVED, I would be golden, but the forum rules don't seem to give me the options stated.

Have a look at this 'manual'