Macro taking a long time to run

andygame

New Member
Joined
May 15, 2021
Messages
7
Office Version
  1. 2016
Platform
  1. Windows
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
ABCDEFGHIJKLMNOPQRSTUVW
1Selected Menus with Ingredients Listing & CostsHRC Number:12345
2
3BBQ Pork ButtReq for 1 GuestFor 187.5 Standard GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
4Pork Butt100g18750gPork Butt (3kg ) 3000Truebites£19.9970£139.93
5Estimated Total:£139.93
6
7Cajun Spiced Whole Roast ChickensReq for 1 GuestFor 187.5 Standard GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
8Whole Chicken0.2Ck37.5ChDis. the Choice Brit. Med Whole Chick (1.35kg)1Booker245519£3.38245363£13.50429£128.26
9Estimated Total:£128.26
10
11Pulled Quarter of Minted LambReq for 1 GuestFor 187.5 Standard GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
12Boneless Lamb Shoulder100g18750gBlackgate Lamb Bon & Roll Lamb Shoulder (2kg)2000Booker229224£26.00n/a£0.000100£260.00
13Estimated Total:£260.00
14
15Grilled Vegetable & Halloumi SkewersReq for 1 GuestFor 62.5 Veg.Veg GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
16Cherry Tomatoes32g2000gFarm Fresh Cherry Tomatoes - (250g)250Booker113509£0.81113508£7.29980£6.48
17Mixed Peppers0.6Bp37.5BpFarm Fresh Mixed Value Peppers (2.5kg) - 3030Booker1133785.9911337723.96420£11.98
18Halloumi Cheese30g1875gVrysaki Halloumi 750g750Booker1936877.6919368645.99630£23.07
19Mushrooms20g1250gFarm Fresh Mushrooms (2500g)2500Booker123397£5.99123396£23.96410£5.99
20Estimated Total:£47.52
21
22Seasonal Green Leaf SaladReq for 1 GuestFor 250 GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
23Mixed Lettuce36g9000gFlorette Classic Crispy (500g)500Booker629340£2.49629330£14.94603£44.82
24Cucumber0.12Cc30CcFarm Fresh Cucumber (1)1Booker187943£0.55187942£7.701422£16.50
25Red Onion0.12Ro30RoFarm Fresh Red Onions (Pack of 3)3Booker120498£0.89120497£17.8020100£8.90
26Pine Nuts8g2000gTesco Wholefoods Pine Nuts (150g)150Tescon/a£5.00n/a£0.000140£70.00
27Olive Oil10.8ml2700mlFilippo Extra Virgin Olive Oil (500ml)500Tescon/a£3.75n/a£0.00060£22.50
28Lemon Juice3.6ml900mlLemon Juice (500ml)500Tescon/a£1.10n/a£0.00020£2.20
29Dijon Mustard1.2g300gGrey Poupon Dijon Mustard (215g)215Tescon/a£1.40n/a£0.00020£2.80
30Garlic Powder0.8g200gEast End Garlic Powder (100g)100Tescon/a£1.15n/a£0.00020£2.30
31Sea Salt0.72g180gTesco Table Salt (750g)750Tescon/a£0.35n/a£0.00010£0.35
32Cracked Black Pepper0.16g40gSchwartz Black Pepper Grinder (35g)35Tescon/a£3.00n/a£0.00020£6.00
33Estimated Total:£176.37
34
35Seasonal Green Leaf SaladReq for 1 GuestFor 250 GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
36Mixed Lettuce36g9000gFlorette Classic Crispy (500g)500Booker629340£2.49629330£14.94603£44.82
37Cucumber0.12Cc30CcFarm Fresh Cucumber (1)1Booker187943£0.55187942£7.701422£16.50
38Red Onion0.12Ro30RoFarm Fresh Red Onions (Pack of 3)3Booker120498£0.89120497£17.8020100£8.90
39Pine Nuts8g2000gTesco Wholefoods Pine Nuts (150g)150Tescon/a£5.00n/a£0.000140£70.00
40Olive Oil10.8ml2700mlFilippo Extra Virgin Olive Oil (500ml)500Tescon/a£3.75n/a£0.00060£22.50
41Lemon Juice3.6ml900mlLemon Juice (500ml)500Tescon/a£1.10n/a£0.00020£2.20
42Dijon Mustard1.2g300gGrey Poupon Dijon Mustard (215g)215Tescon/a£1.40n/a£0.00020£2.80
43Garlic Powder0.8g200gEast End Garlic Powder (100g)100Tescon/a£1.15n/a£0.00020£2.30
44Sea Salt0.72g180gTesco Table Salt (750g)750Tescon/a£0.35n/a£0.00010£0.35
45Cracked Black Pepper0.16g40gSchwartz Black Pepper Grinder (35g)35Tescon/a£3.00n/a£0.00020£6.00
46Estimated Total:£176.37
47
48Corn CobettesReq for 1 GuestFor 250 GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
49Corn on the cob0.5Cb125CbHuercasa Ckd. Corn on the Cob (450g) Pack of 22Booker97224£1.7997223£21.481235£112.77
50Butter15g3750gTesco British Salted Block Butter (250g)250Tescon/a£1.48n/a£0.000150£22.20
51Estimated Total:£134.97
52
53Mix of Sweet Potato & Standard FriesReq for 1 GuestFor 250 GuestsDetailWt/Qty of 1 UnitSupplierUnit Product CodeUnit CostMulti Product CodeMulti Pack CostNo. Units in MultiUnits ReqMulti ReqTotal Costs
54Sweet Potato Fries75g18750gChef's Larder Sweet Potato Fries (2.5kg)2500Booker265103£6.49265102£25.95441£51.91
55Standard Fries75g18750gChef's Larder Premium French Fries (2.5kg)2500Booker182764£3.19182763£12.75441£25.51
56Cooking Oil (for fryer)0.12Ltr30LtrChef's Larder Sunflower Oil (5 Ltr)5Booker105472£9.99105459£29.95302£59.90
57Estimated Total:£137.32
Menu_Breakdown
Cell Formulas
RangeFormula
U1U1=SUM('Contact_&_Menus'!B3)
E3,E11,E7E3="For "&No._Standards& " Standard Guests"
E4,E12,E8E4=SUM(No._Standards*C4)
T4,T54:T56,T49:T50,T36:T45,T23:T32,T16:T19,T12,T8T4=ROUNDUP(SUM(E4/H4)-(U4*R4),0)
U4,U54:U56,U12,U8U4=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,W8W4=SUM(L4*T4)+SUM(P4*U4)
W5,W51,W13,W9W5=SUM(W3:W4)
U49:U50,U36:U45,U23:U32,U16:U19U16=IFERROR((ROUNDDOWN((IF((E16/H16>=R16),(E16/H16/R16),0)),0)),0)
E15E15="For "&No._Vegetarians& " Veg.Veg Guests"
E16:E19E16=SUM(No._Vegetarians*C16)
W20W20=SUM(W16:W19)
E22,E53,E48,E35E22="For "&No._Attendees& " Guests"
E54:E56,E49:E50,E36:E45,E23:E32E23=SUM(No._Attendees*C23)
W33,W46W33=SUM(W23:W32)
W57W57=SUM(W54:W56)
Named Ranges
NameRefers ToCells
No._Attendees='Contact_&_Menus'!$B$10E53:E56, E48:E50, E22:E32, E35:E45
No._Standards='Contact_&_Menus'!$A$24E11:E12, E7:E8, E3:E4
No._Vegetarians='Contact_&_Menus'!$B$24E15:E19








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

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

jasonb75

Well-known Member
Joined
Dec 30, 2008
Messages
14,540
Office Version
  1. 365
Platform
  1. Windows
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).
VBA Code:
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

Well-known Member
Joined
Dec 30, 2008
Messages
14,540
Office Version
  1. 365
Platform
  1. Windows
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.
VBA Code:
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
 
Solution

andygame

New Member
Joined
May 15, 2021
Messages
7
Office Version
  1. 2016
Platform
  1. Windows
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.
VBA Code:
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.
 

Forum statistics

Threads
1,147,823
Messages
5,743,406
Members
423,792
Latest member
travisds

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top