Macro taking a long time to run

[andygame]

Hi all . . .

Before I start - please bear with me, I only started learning VBA code about a week ago - so I'd be grateful for helpful comments only.

Quick synopsis: I have a spreadsheet that compiles a list of menus together with that menus specific ingredients onto a worksheet (Menu_Breakdown). I am then pulling certain elements from Menu_Breakdown onto a new sheet (Shopping_List).

(The elements I am selecting are always the same and are always in one row: eg. Supplier, Unit Code, Unit Qty etc, but there is some information like costs etc that I do not need for the shopping list.)

Now the macro runs fine and does exactly what I want it to do - BUT, it is taking a long time considering the relatively small amount of information its processing. Reading a previous thread, I think this might be because of the way I am copying the information from one sheet to the other - not sure.

I'm hoping that someone can view the code and instantly see why its taking so long (and give me a solution to sort out the problem). As this is still new to me, an explanation of why its taking so long and (if you give a solution) why your solution will work much better. I apologise in advance for the poor coding - there has been a lot of cursing and swearing over the last week, copying and pasting from snipets of code on the web, analysing why they do what they do - and then trying to emulate that in my own way.

The following is a Mini-sheet of the Menu_Breakdown sheet - followed by the macro I'm having trouble with.

The Menu_Breakdown sheet is automatically compiled by user input on a different sheet in the workbook.

Blank Job Sheet 012.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1	Selected Menus with Ingredients Listing & Costs															HRC Number:					12345
2
3	BBQ Pork Butt		Req for 1 Guest		For 187.5 Standard Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
4	Pork Butt		100	g	18750	g	Pork Butt (3kg )	3000	Truebites			£19.99								7	0		£139.93
5																				Estimated Total:			£139.93
6
7	Cajun Spiced Whole Roast Chickens		Req for 1 Guest		For 187.5 Standard Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
8	Whole Chicken		0.2	Ck	37.5	Ch	Dis. the Choice Brit. Med Whole Chick (1.35kg)	1	Booker	245519		£3.38		245363		£13.50		4		2	9		£128.26
9																				Estimated Total:			£128.26
10
11	Pulled Quarter of Minted Lamb		Req for 1 Guest		For 187.5 Standard Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
12	Boneless Lamb Shoulder		100	g	18750	g	Blackgate Lamb Bon & Roll Lamb Shoulder (2kg)	2000	Booker	229224		£26.00		n/a		£0.00		0		10	0		£260.00
13																				Estimated Total:			£260.00
14
15	Grilled Vegetable & Halloumi Skewers		Req for 1 Guest		For 62.5 Veg.Veg Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
16	Cherry Tomatoes		32	g	2000	g	Farm Fresh Cherry Tomatoes - (250g)	250	Booker	113509		£0.81		113508		£7.29		9		8	0		£6.48
17	Mixed Peppers		0.6	Bp	37.5	Bp	Farm Fresh Mixed Value Peppers (2.5kg) - 30	30	Booker	113378		5.99		113377		23.96		4		2	0		£11.98
18	Halloumi Cheese		30	g	1875	g	Vrysaki Halloumi 750g	750	Booker	193687		7.69		193686		45.99		6		3	0		£23.07
19	Mushrooms		20	g	1250	g	Farm Fresh Mushrooms (2500g)	2500	Booker	123397		£5.99		123396		£23.96		4		1	0		£5.99
20																				Estimated Total:			£47.52
21
22	Seasonal Green Leaf Salad		Req for 1 Guest		For 250 Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
23	Mixed Lettuce		36	g	9000	g	Florette Classic Crispy (500g)	500	Booker	629340		£2.49		629330		£14.94		6		0	3		£44.82
24	Cucumber		0.12	Cc	30	Cc	Farm Fresh Cucumber (1)	1	Booker	187943		£0.55		187942		£7.70		14		2	2		£16.50
25	Red Onion		0.12	Ro	30	Ro	Farm Fresh Red Onions (Pack of 3)	3	Booker	120498		£0.89		120497		£17.80		20		10	0		£8.90
26	Pine Nuts		8	g	2000	g	Tesco Wholefoods Pine Nuts (150g)	150	Tesco	n/a		£5.00		n/a		£0.00		0		14	0		£70.00
27	Olive Oil		10.8	ml	2700	ml	Filippo Extra Virgin Olive Oil (500ml)	500	Tesco	n/a		£3.75		n/a		£0.00		0		6	0		£22.50
28	Lemon Juice		3.6	ml	900	ml	Lemon Juice (500ml)	500	Tesco	n/a		£1.10		n/a		£0.00		0		2	0		£2.20
29	Dijon Mustard		1.2	g	300	g	Grey Poupon Dijon Mustard (215g)	215	Tesco	n/a		£1.40		n/a		£0.00		0		2	0		£2.80
30	Garlic Powder		0.8	g	200	g	East End Garlic Powder (100g)	100	Tesco	n/a		£1.15		n/a		£0.00		0		2	0		£2.30
31	Sea Salt		0.72	g	180	g	Tesco Table Salt (750g)	750	Tesco	n/a		£0.35		n/a		£0.00		0		1	0		£0.35
32	Cracked Black Pepper		0.16	g	40	g	Schwartz Black Pepper Grinder (35g)	35	Tesco	n/a		£3.00		n/a		£0.00		0		2	0		£6.00
33																				Estimated Total:			£176.37
34
35	Seasonal Green Leaf Salad		Req for 1 Guest		For 250 Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
36	Mixed Lettuce		36	g	9000	g	Florette Classic Crispy (500g)	500	Booker	629340		£2.49		629330		£14.94		6		0	3		£44.82
37	Cucumber		0.12	Cc	30	Cc	Farm Fresh Cucumber (1)	1	Booker	187943		£0.55		187942		£7.70		14		2	2		£16.50
38	Red Onion		0.12	Ro	30	Ro	Farm Fresh Red Onions (Pack of 3)	3	Booker	120498		£0.89		120497		£17.80		20		10	0		£8.90
39	Pine Nuts		8	g	2000	g	Tesco Wholefoods Pine Nuts (150g)	150	Tesco	n/a		£5.00		n/a		£0.00		0		14	0		£70.00
40	Olive Oil		10.8	ml	2700	ml	Filippo Extra Virgin Olive Oil (500ml)	500	Tesco	n/a		£3.75		n/a		£0.00		0		6	0		£22.50
41	Lemon Juice		3.6	ml	900	ml	Lemon Juice (500ml)	500	Tesco	n/a		£1.10		n/a		£0.00		0		2	0		£2.20
42	Dijon Mustard		1.2	g	300	g	Grey Poupon Dijon Mustard (215g)	215	Tesco	n/a		£1.40		n/a		£0.00		0		2	0		£2.80
43	Garlic Powder		0.8	g	200	g	East End Garlic Powder (100g)	100	Tesco	n/a		£1.15		n/a		£0.00		0		2	0		£2.30
44	Sea Salt		0.72	g	180	g	Tesco Table Salt (750g)	750	Tesco	n/a		£0.35		n/a		£0.00		0		1	0		£0.35
45	Cracked Black Pepper		0.16	g	40	g	Schwartz Black Pepper Grinder (35g)	35	Tesco	n/a		£3.00		n/a		£0.00		0		2	0		£6.00
46																				Estimated Total:			£176.37
47
48	Corn Cobettes		Req for 1 Guest		For 250 Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
49	Corn on the cob		0.5	Cb	125	Cb	Huercasa Ckd. Corn on the Cob (450g) Pack of 2	2	Booker	97224		£1.79		97223		£21.48		12		3	5		£112.77
50	Butter		15	g	3750	g	Tesco British Salted Block Butter (250g)	250	Tesco	n/a		£1.48		n/a		£0.00		0		15	0		£22.20
51																				Estimated Total:			£134.97
52
53	Mix of Sweet Potato & Standard Fries		Req for 1 Guest		For 250 Guests		Detail	Wt/Qty of 1 Unit	Supplier	Unit Product Code		Unit Cost		Multi Product Code		Multi Pack Cost		No. Units in Multi		Units Req	Multi Req		Total Costs
54	Sweet Potato Fries		75	g	18750	g	Chef's Larder Sweet Potato Fries (2.5kg)	2500	Booker	265103		£6.49		265102		£25.95		4		4	1		£51.91
55	Standard Fries		75	g	18750	g	Chef's Larder Premium French Fries (2.5kg)	2500	Booker	182764		£3.19		182763		£12.75		4		4	1		£25.51
56	Cooking Oil (for fryer)		0.12	Ltr	30	Ltr	Chef's Larder Sunflower Oil (5 Ltr)	5	Booker	105472		£9.99		105459		£29.95		3		0	2		£59.90
57																				Estimated Total:			£137.32
Menu_Breakdown

Cell Formulas
Range	Formula
U1	U1	=SUM('Contact_&_Menus'!B3)
E3,E11,E7	E3	="For "&No._Standards& " Standard Guests"
E4,E12,E8	E4	=SUM(No._Standards*C4)
T4,T54:T56,T49:T50,T36:T45,T23:T32,T16:T19,T12,T8	T4	=ROUNDUP(SUM(E4/H4)-(U4*R4),0)
U4,U54:U56,U12,U8	U4	=IFERROR((ROUNDDOWN((IF((E4/H4>=R4),(E4/H4/R4*1),0)),0)),0)
W4,W54:W56,W49:W50,W36:W45,W23:W32,W16:W19,W12,W8	W4	=SUM(L4*T4)+SUM(P4*U4)
W5,W51,W13,W9	W5	=SUM(W3:W4)
U49:U50,U36:U45,U23:U32,U16:U19	U16	=IFERROR((ROUNDDOWN((IF((E16/H16>=R16),(E16/H16/R16),0)),0)),0)
E15	E15	="For "&No._Vegetarians& " Veg.Veg Guests"
E16:E19	E16	=SUM(No._Vegetarians*C16)
W20	W20	=SUM(W16:W19)
E22,E53,E48,E35	E22	="For "&No._Attendees& " Guests"
E54:E56,E49:E50,E36:E45,E23:E32	E23	=SUM(No._Attendees*C23)
W33,W46	W33	=SUM(W23:W32)
W57	W57	=SUM(W54:W56)

Named Ranges
Name	Refers To	Cells
No._Attendees	='Contact_&_Menus'!$B$10	E53:E56, E48:E50, E22:E32, E35:E45
No._Standards	='Contact_&_Menus'!$A$24	E11:E12, E7:E8, E3:E4
No._Vegetarians	='Contact_&_Menus'!$B$24	E15:E19

Sub Create_the_Shopping_List()

Application.StatusBar = "Please wait - compiling Shopping List"

'Check to see if there are any Menus on the Menu Breakdown Sheet - if not then exit this routine with a message
        
        Sheets("Menu_Breakdown").Select

        If IsEmpty(Range("A3").Value) = True Then
        
        MsgBox "There are no Menus to create a Shopping List"
        Sheets("Contact_&_Menus").Select
        
        Exit Sub
      
        End If
    



'Turns screen updating off

    Application.ScreenUpdating = False

'Insert the Headings

Sheets("Shopping_List").Select

Range("A1") = "Detail"
Range("B1") = "Supplier"
Range("C1") = "Unit Code"
Range("D1") = "Unit Qty"
Range("E1") = "Multi Code"
Range("F1") = "Multi Qty"
Range("G1") = "Purchased"

Range("A1:G1").Select
    Selection.Font.Bold = True
    Selection.Font.Italic = True
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With


'Changes the row Height of the headings

    Range("A1").RowHeight = 48



'Initialise the variables

    Set shtMB = Worksheets("Menu_Breakdown")
    Set shtSL = Worksheets("Shopping_List")

    Dim IngredCount As Integer


'Select Menu Breakdown as the sheet on which to perform the routine

    Sheets("Menu_Breakdown").Select




'Evaluate how many time the word "Detail appears on the page (hence the number of Menus) - set this value as DetailCount

    Dim DetailCount As Long

    DetailCount = Application.WorksheetFunction.CountIf(ActiveSheet.Cells, "Detail")



'Check if the value of DetailCount is 0 - If so, display message and end routine

    If DetailCount = 0 Then
    Sheets("Contact_&_Menus").Activate
    MsgBox "You have not Created any Menus Yet"
    Exit Sub
    
        
    End If



'See where the first menu starts by checking for the first empty cell in column G, and set that line number to variable First Item

    Dim FirstItem As Integer
    
    FirstItem = 2
    
    
    FirstItem = Range("G" & FirstItem, "G" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
    
    FirstItem = FirstItem + 2
 


'See where the first menu ends by checking for the first empty cell in column G (after the above), and set that line number to variable LastItem

    Dim LastItem As Integer

    LastItem = Range("G" & FirstItem, "G" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row

    IngredCount = (LastItem - FirstItem)
    
      

'Set the parameters for copying the first menu

    Dim MenuRow As Long
    Dim ShoppingRow As Long
    
    MenuRow = FirstItem
    ShoppingRow = 2
    
    Dim N As Integer
    Dim S As Integer
 
' Loop sequence that copies the ingredients of each menu into a single list on the Shopping list sheet

    For S = 1 To DetailCount
 
    For N = 1 To IngredCount
    
'Copy and Paste elements from the Menu to the Shopping List
    
    shtMB.Range("G" & MenuRow).Copy
    shtSL.Range("A" & ShoppingRow).PasteSpecial xlPasteValues
    shtMB.Range("I" & MenuRow).Copy
    shtSL.Range("B" & ShoppingRow).PasteSpecial xlPasteValues
    shtMB.Range("J" & MenuRow).Copy
    shtSL.Range("C" & ShoppingRow).PasteSpecial xlPasteValues
    shtMB.Range("T" & MenuRow).Copy
    shtSL.Range("D" & ShoppingRow).PasteSpecial xlPasteValues
    shtMB.Range("N" & MenuRow).Copy
    shtSL.Range("E" & ShoppingRow).PasteSpecial xlPasteValues
    shtMB.Range("U" & MenuRow).Copy
    shtSL.Range("F" & ShoppingRow).PasteSpecial xlPasteValues

    MenuRow = MenuRow + 1
    ShoppingRow = ShoppingRow + 1
 
    Next N

    MenuRow = MenuRow + 3

    FirstItem = MenuRow

    LastItem = Range("G" & MenuRow, "G" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row

    IngredCount = (LastItem - FirstItem)
    
    Next S


'Get the position of the last row in the Shopping List

    Dim FinalShoppingRow As Integer

    FinalShoppingRow = ShoppingRow - 1

    Sheets("Shopping_List").Select

' Selects a range equal to the entire Shopping List plus the Purchased Column then puts a black border around all cells

    Dim iRange As Range
    Dim iCells As Range

    Set iRange = Range("A1", "G" & FinalShoppingRow)

    For Each iCells In iRange
            iCells.BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin
    Next iCells


'Turns the Shopping List into a Table called Shopping


Dim src As Range
Dim ws As Worksheet
Set src = Range("A1", "G" & FinalShoppingRow).CurrentRegion
Set ws = ActiveSheet
ws.ListObjects.Add(SourceType:=xlSrcRange, Source:=src, _
xlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleLight2").Name = "Shopping"


'Align all cells properly
        Range("A2", "G" & FinalShoppingRow).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Range("A1", "A" & FinalShoppingRow).Select
    
    With Selection
        .HorizontalAlignment = xlLeft
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Range("A1").Select
    

'Turns screen updating on

    Application.ScreenUpdating = True

Application.StatusBar = "Ready"


End Sub

 

[jasonb75]

I only started learning VBA code about a week ago

You've done quite well for a beginner

I think this might be because of the way I am copying the information from one sheet to the other

At a quick glance, that would appear to be one possibility. Using 'Select' also slows things down although it shouldn't be too bad with your code (unless I've missed something).
As you have formulas in your sheet, setting calculation to manual while the code runs can also help. As with selection, I don't think that it is a significant problem with your code.

As far as the copying goes, given that you only want the cell values it would be much quicker to do it without copying at all. For example, you could use something like this to speed up the row by row copy with your existing loops (just one as an example, you would need to do the same for each copy and paste pair).

shtSL.Range("A" & ShoppingRow).Value = shtMB.Range("G" & MenuRow).Value

It is highly likely that you would be able to bulk copy for at least one loop, if not both of them (copy from first row to last as a single action instead of one cell at a time).I'm digging into your code now to see if that will work but it could take a while.

 

[jasonb75]

See if this works for you, It runs almost instantly on my laptop using your sample data compared to 3 or 4 seconds for your original code. I've tried to keep the functions of your code while removing the extra bits that you didn't need. Hopefully I haven't missed anything.

Option Explicit
Sub Create_the_Shopping_List()
    ' declare variables
Dim shtSL As Worksheet, shtMB As Worksheet
Dim MBlastrow As Long

    ' assign values to variables

Set shtSL = Worksheets("Shopping_List")
Set shtMB = Worksheets("Menu_Breakdown")
MBlastrow = shtMB.Cells(Rows.Count, 1).End(xlUp).Row

    'Check to see if there are any Menus on the Menu Breakdown Sheet - if not then exit this routine with a message

If shtMB.Range("A3").Value = "" Then
    MsgBox "There are no Menus to create a Shopping List"
    Sheets("Contact_&_Menus").Select
    Exit Sub
End If
    
    'Turns screen updating off

Application.ScreenUpdating = False

    'Insert the Headings

With shtSL
    .Range("A1") = "Detail"
    .Range("B1") = "Supplier"
    .Range("C1") = "Unit Code"
    .Range("D1") = "Unit Qty"
    .Range("E1") = "Multi Code"
    .Range("F1") = "Multi Qty"
    .Range("G1") = "Purchased"

    With .Range("A1:G1")
        .Font.Bold = True
        .Font.Italic = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .RowHeight = 48
    End With

End With

With shtMB
    .Range("$G$2:$G$" & MBlastrow).AutoFilter Field:=1, Criteria1:="<>", Operator:=xlAnd, Criteria2:="<>Detail"
    With .Range("$G$3:$G$" & MBlastrow).SpecialCells(xlVisible)
        .Copy
        shtSL.Range("A2").PasteSpecial (xlValues)
        .Offset(, 2).Copy
        shtSL.Range("B2").PasteSpecial (xlValues)
        .Offset(, 3).Copy
        shtSL.Range("C2").PasteSpecial (xlValues)
        .Offset(, 13).Copy
        shtSL.Range("D2").PasteSpecial (xlValues)
        .Offset(, 7).Copy
        shtSL.Range("E2").PasteSpecial (xlValues)
        .Offset(, 14).Copy
        shtSL.Range("F2").PasteSpecial (xlValues)
        Application.CutCopyMode = False
        .AutoFilter
    End With
End With

'See where the first menu starts by checking for the first empty cell in column G, and set that line number to variable First Item

Dim src As Range
Set src = shtSL.Range("A1").CurrentRegion
shtSL.ListObjects.Add(SourceType:=xlSrcRange, Source:=src, _
xlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleLight2").Name = "Shopping"

'Align all cells properly
With src
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .Borders.LineStyle = xlSolid
    .Columns.AutoFit
End With

'Turns screen updating on
    Application.ScreenUpdating = True
End Sub

 

[andygame]

See if this works for you, It runs almost instantly on my laptop using your sample data compared to 3 or 4 seconds for your original code. I've tried to keep the functions of your code while removing the extra bits that you didn't need. Hopefully I haven't missed anything.

Option Explicit
Sub Create_the_Shopping_List()
    ' declare variables
Dim shtSL As Worksheet, shtMB As Worksheet
Dim MBlastrow As Long

    ' assign values to variables

Set shtSL = Worksheets("Shopping_List")
Set shtMB = Worksheets("Menu_Breakdown")
MBlastrow = shtMB.Cells(Rows.Count, 1).End(xlUp).Row

    'Check to see if there are any Menus on the Menu Breakdown Sheet - if not then exit this routine with a message

If shtMB.Range("A3").Value = "" Then
    MsgBox "There are no Menus to create a Shopping List"
    Sheets("Contact_&_Menus").Select
    Exit Sub
End If
   
    'Turns screen updating off

Application.ScreenUpdating = False

    'Insert the Headings

With shtSL
    .Range("A1") = "Detail"
    .Range("B1") = "Supplier"
    .Range("C1") = "Unit Code"
    .Range("D1") = "Unit Qty"
    .Range("E1") = "Multi Code"
    .Range("F1") = "Multi Qty"
    .Range("G1") = "Purchased"

    With .Range("A1:G1")
        .Font.Bold = True
        .Font.Italic = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .RowHeight = 48
    End With

End With

With shtMB
    .Range("$G$2:$G$" & MBlastrow).AutoFilter Field:=1, Criteria1:="<>", Operator:=xlAnd, Criteria2:="<>Detail"
    With .Range("$G$3:$G$" & MBlastrow).SpecialCells(xlVisible)
        .Copy
        shtSL.Range("A2").PasteSpecial (xlValues)
        .Offset(, 2).Copy
        shtSL.Range("B2").PasteSpecial (xlValues)
        .Offset(, 3).Copy
        shtSL.Range("C2").PasteSpecial (xlValues)
        .Offset(, 13).Copy
        shtSL.Range("D2").PasteSpecial (xlValues)
        .Offset(, 7).Copy
        shtSL.Range("E2").PasteSpecial (xlValues)
        .Offset(, 14).Copy
        shtSL.Range("F2").PasteSpecial (xlValues)
        Application.CutCopyMode = False
        .AutoFilter
    End With
End With

'See where the first menu starts by checking for the first empty cell in column G, and set that line number to variable First Item

Dim src As Range
Set src = shtSL.Range("A1").CurrentRegion
shtSL.ListObjects.Add(SourceType:=xlSrcRange, Source:=src, _
xlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleLight2").Name = "Shopping"

'Align all cells properly
With src
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .Borders.LineStyle = xlSolid
    .Columns.AutoFit
End With

'Turns screen updating on
    Application.ScreenUpdating = True
End Sub

Hi Jason - OUTSTANDING. Swapped it for my macro and it ran and compiled instantly. I shall now spend the next week trying to understand the code. Top Job.