Optimising my VBA to improve the efficiency of my Workbook

Tmini

New Member
Joined
Mar 22, 2014
Messages
44
Office Version
  1. 365
Platform
  1. Windows
Hi
I have set up a system that I use for work whereas I will quote up a job with all of the materials output as a list. Each workbook is a new unit that has it's own list of materials. They are all stored in a different job folder for each job. I then have another workbook with VBA code where I click a button find the job folder and then the VBA will work it's magic and open each file within that folder copy all of the materials data from each workbook into one final workbook. It has several sheets within it that will show different data sets depending on the information I need for each job. One of the data sets is a list of materials for each of the units. I have it so it copies all of the materials data from each workbook that it opens, Pastes the values and then I have it delete all of the irrelevant data with no value. The problem is when I have a large job of 500 files or so it can take 7 hours to run through every single workbook and delete all of the data with no value. Now I know my issue is running it so it iterates through it one line at a time but I am unsure how to make it so it will sort it all so all of the no value data is at the top and it deletes that straight away then it re-sorts itself back into the order that it should be. I have guessed that it will take a 7 hour job and reduce it to less than an hour if I can figure out how to optimise it.
With my first screenshot that is my initial job unit workbook as you can see it runs from line 1 all the way through to line 289 - this is where my materials list ends. I have to copy the entire list because every unit will have a different list of materials which is listed from rows 16 through to 289 and only shows when that material is needed for the job. When this is copied over to the new workbook I can have several hundred files copied over and that adds up to hundreds of thousands of rows with many blank rows which are all deleted. My initial thoughts are to try and number each row in alphanumeric order as they are always the same amount of rows and for each new work book that is copied have a formula which will add those numbers up from the previous workbook to number alphanumerically all the way through 1- however many rows it ends up being. I would ideally get it to sort through the data and organise it so all blank data rows are at the top and have it delete all of those rows and then have it do another sort from the alphanumeric data column to go from smallest to largest to put it back in order. I am just unsure how to do this. If anyone can help on this that would be great and it would save me so much time when I'm under the pump

The code that I use to sort the data and delete the non value rows is as follows
VBA Code:
Sub delrowsifzero1()

    Application.ScreenUpdating = False

    Dim LastRow As Long

     Worksheets("Itemised Detail").Activate

     On Error Resume Next

       LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    Dim x As Long

    ActiveWorkbook.Worksheets("Itemised Detail").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("Itemised Detail").Sort.SortFields.Add Key:=Range("A:a" & LastRow) _

        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("Itemised Detail").Sort

        .SetRange Range("A:a" & LastRow)

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    For x = LastRow To 2 Step -1

        If Cells(x, 1) = "" Or Cells(x, 1) = 0 Then

            Rows(x).EntireRow.Delete

        End If

    Next x

    Application.ScreenUpdating = True

    Application.CutCopyMode = False

  

            'Hide worksheets

    Worksheets("Overall Costs").Visible = xlSheetHidden

    Worksheets("Single Unit Pricing").Visible = xlSheetHidden

    Worksheets("Total Hours For All Units").Visible = xlSheetHidden

    Worksheets("Single Unit Hours").Visible = xlSheetHidden

      End Sub
 

Attachments

  • Screenshot 2023-08-11 210153.jpg
    Screenshot 2023-08-11 210153.jpg
    193.9 KB · Views: 24
  • Screenshot 2023-08-11 210429.jpg
    Screenshot 2023-08-11 210429.jpg
    186.4 KB · Views: 26
Sorry, there is no way that I can make any sense of all that.
I thought the problem was about deleting rows efficiently.
 
Upvote 0

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sorry, there is no way that I can make any sense of all that.
I thought the problem was about deleting rows efficiently.
The problem is with deleting the rows efficiently - that is why I only included the code that related to my issue. I did try to explain it as best I could in the beginning.
1 - I have a folder with many workbooks in it that have all sorts of data and is summarised at the end of the last worksheet called total quantities
2 - I have another workbook with a button I press that allows me to search for the job folder with all of those workbooks
VBA Code:
Option Explicit
Sub RunAllMacros()
Dim startTime As Date
    startTime = Now
    
    CommandButton1_Click
    test
    sortMyData
    delrowsifzero
    consolidatedata
    delrowsifzero1
    
    Dim endTime As Date
    endTime = Now
    
    Dim elapsedTime As Date
    elapsedTime = endTime - startTime
    
    MsgBox "Macro execution time: " & Format(elapsedTime, "hh:mm:ss")
End Sub
Sub CommandButton1_Click()
    Dim x, fldr As FileDialog, SelFold As String, i As Long
    Dim ws As Worksheet, ws0, ws1, ws2, ws3, Ws4, Ws5 As Worksheet
    Dim Wb As Workbook, Filename As String
    Dim screenUpdateState As String
    Dim statusBarState As String
    Dim eventsState As String
    Dim lngrow As Long
    Dim lngrow1 As Long
    Dim lngrow2 As Long
    Dim lngrow3 As Long
    
    
        
    
    screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
eventsState = Application.EnableEvents

'turn off some Excel functionality for faster performance
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False


    'User Selects desired Folder
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        If .Show <> -1 Then GoTo Cleanup
        SelFold = .SelectedItems(1)
    End With

    'All .xls* files in Selected FolderPath including Sub folders are put into an array
    x = Split(CreateObject("wscript.shell").exec("c:\temp\cmd.exe /c Dir """ & SelFold & "\*.xls"" /s/b").stdout.readall, vbCrLf)
    
     Set ws1 = ThisWorkbook.Sheets("Labour & Material")
     Set ws2 = ThisWorkbook.Sheets("Total Hours For All Units")
     Set ws3 = ThisWorkbook.Sheets("Materials Summary")
     Set Ws4 = ThisWorkbook.Sheets("Breakdowns")
     Set Ws5 = ThisWorkbook.Sheets("Itemised Detail")
    
    'Loop through that array
    For i = LBound(x) To UBound(x) - 1

    'Open (in background) the Workbook
        With GetObject(x(i))
        
    'Unhide worksheets
    Worksheets("Overall Costs").Visible = xlSheetVisible
    Worksheets("Single Unit Pricing").Visible = xlSheetVisible
    Worksheets("Total Hours For All Units").Visible = xlSheetVisible
    Worksheets("Single Unit Hours").Visible = xlSheetVisible
          
            ThisWorkbook.Sheets(1).UsedRange
            Filename = Split(x(i), "\")(UBound(Split(x(i), "\")))
       Set Wb = Workbooks(Filename)
        Set ws = Nothing
        Set ws0 = Nothing
        'On Error Resume Next
        'change sheet name here
        Set ws = Wb.Sheets("Total Quantities")
        Set ws0 = Wb.Sheets("Builder Costings")
        On Error GoTo 0
        If Not ws Is Nothing Then
        If lngrow1 = 0 Then
        lngrow1 = 5
    Else
        lngrow3 = lngrow3 + 308
        lngrow2 = lngrow2 + 11
        lngrow1 = lngrow1 + 1
        lngrow = lngrow + 293
    End If
        ws1.Cells(lngrow1, "A").Value = ws.Range("A1").Value
        ws1.Cells(lngrow1, "B").Value = ws.Range("I2").Value
        ws1.Cells(lngrow1, "C").Value = ws.Range("C2").Value
        ws1.Cells(lngrow1, "E").Value = ws.Range("C3").Value
        ws1.Cells(lngrow1, "G").Value = ws.Range("C4").Value
        ws2.Cells(lngrow1, "B").Value = ws.Range("B8").Value
        ws2.Cells(lngrow1, "C").Value = ws.Range("B9").Value
        ws2.Cells(lngrow1, "D").Value = ws.Range("B10").Value
        ws2.Cells(lngrow1, "E").Value = ws.Range("B11").Value
        ws2.Cells(lngrow1, "F").Value = ws.Range("B12").Value
        ws2.Cells(lngrow1, "G").Value = ws.Range("B13").Value
        ws2.Cells(lngrow1, "H").Value = ws.Range("B14").Value
        ws3.Range("A2:A237").Offset(lngrow, 0).Value = ws.Range("A16:A251").Value
        ws3.Range("B2:B237").Offset(lngrow, 0).Value = ws.Range("C16:C251").Value
        ws3.Range("E2:E237").Offset(lngrow, 0).Value = ws.Range("H16:H251").Value
        ws3.Range("D2:D237").Offset(lngrow, 0).Value = ws.Range("E16:E251").Value
        ws3.Range("F2:F237").Offset(lngrow, 0).Value = ws.Range("F16:F251").Value
        ws3.Range("A238:A284").Offset(lngrow, 0).Value = ws.Range("I16:I62").Value
        ws3.Range("b238:b284").Offset(lngrow, 0).Value = ws.Range("J16:J62").Value
        ws3.Range("d238:d284").Offset(lngrow, 0).Value = ws.Range("K16:K62").Value
        ws3.Range("e238:e284").Offset(lngrow, 0).Value = ws.Range("l16:l62").Value
        ws3.Range("A285:A293").Offset(lngrow, 0).Value = ws.Range("I64:I72").Value
        ws3.Range("b285:b293").Offset(lngrow, 0).Value = ws.Range("J64:J72").Value
        ws3.Range("d285:d293").Offset(lngrow, 0).Value = ws.Range("K64:K72").Value
        ws.Range("I74:K83").Copy
        Ws4.Range("A2:C11").Offset(lngrow2, 0).PasteSpecial Paste:=xlPasteValues
        Ws4.Range("A2:C11").Offset(lngrow2, 0).PasteSpecial Paste:=xlPasteFormats
        ws0.Range("A1:C14").Copy
        Ws5.Range("A1:C14").Offset(lngrow3).PasteSpecial xlPasteFormats
        Ws5.Range("A1:C14").Offset(lngrow3).PasteSpecial xlPasteValues
        ws0.Range("H1:i2").Copy
        Ws5.Range("E1:f2").Offset(lngrow3).PasteSpecial xlPasteFormats
        Ws5.Range("E1:f2").Offset(lngrow3).PasteSpecial xlPasteValues
        ws0.Range("H3:h4").Copy
        Ws5.Range("d1:d2").Offset(lngrow3).PasteSpecial xlPasteFormats
        Ws5.Range("d1:d2").Offset(lngrow3).PasteSpecial xlPasteValues
        ws0.Range("H15:j23").Copy
        Ws5.Range("a15:c23").Offset(lngrow3).PasteSpecial xlPasteFormats
        Ws5.Range("a15:c23").Offset(lngrow3).PasteSpecial xlPasteValues
        ws0.Range("A15:f298").Copy
        Ws5.Range("A24:f307").Offset(lngrow3).PasteSpecial xlPasteFormats
        Ws5.Range("A24:f307").Offset(lngrow3).PasteSpecial xlPasteValues
      Wb.Application.CutCopyMode = False
        End If
            .Close
        End With
    Next i
3 - Once I have selected that folder the macros run through each workbook copying the data from the total quantities worksheet and pastes it into my workbook as raw data
4 - There is a macro which copies some summarised data to a breakdowns worksheet and sorts through that particular data and deletes the rows that I need deleted
Code:
 ' Delete rows in the Breakdowns worksheet where column C has a zero value
With Ws4
    Dim deleteRange As Range
    Dim lastRow As Long
    lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
    
    ' Loop through the rows in reverse order
    For i = lastRow To 2 Step -1
        If .Cells(i, "C").Value = 0 Then
            If deleteRange Is Nothing Then
                Set deleteRange = .Rows(i)
            Else
                Set deleteRange = Union(deleteRange, .Rows(i))
            End If
        End If
    Next i
    
    ' Delete the range of rows in one operation (if any rows need to be deleted)
    If Not deleteRange Is Nothing Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
        
        deleteRange.Delete
        
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End With
Cleanup:
    Set fldr = Nothing
End Sub
5 - There is a macro which copies the material data to a materials worksheet and sorts through that data adds up all the quantities and costs of materials and collates all of the many multiples together into one itemised list
Code:
Sub test()
Dim SheetNum As Variant
Dim Sh As Variant
Dim SoRng As Variant
Dim ColNo As Variant
Dim Col As Variant



SheetNum = Array(2, 3, 6, 8)
For Each Sh In Sheets(SheetNum)
    Sh.Select
    Set SoRng = Sh.Range("A5", Sh.Range("A5").End(xlToRight).Address)
    AdvFil SoRng
Next

Sheets(5).Select
Set SoRng = Sheets(5).Range("A5:A5")
AdvFil SoRng

Sheets(5).Select
Set SoRng = Sheets(5).Range("i5:q5")
AdvFil SoRng

Sheets(4).Select
ColNo = Array("D", "F", "H")
    For Each Col In ColNo
    Set SoRng = Sheets(4).Range(Col & "5:" & Col & "5")
    AdvFil SoRng
Next

End Sub
Sub AdvFil(ByVal x As Range)
Dim LrNum As String
Dim DesRng As Variant

LrNum = Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
If InStr(1, x.Address, ":") > 0 Then
    DesRng = Left(x.Address, Len(x.Address) - 1) & LrNum
Else
    DesRng = x.Address & ":" & Left(x.Address, Len(x.Address) - 1) & LrNum
End If
x.AutoFill Destination:=Range(DesRng)
End Sub
Sub sortMyData()

Dim lastRow As Long
Dim myRng As Range

With ActiveWorkbook.Worksheets("Materials Summary")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set myRng = .Range("a1:f" & lastRow)
myRng.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

End With

End Sub
Sub delrowsifzero()
    Application.ScreenUpdating = False
    Dim lastRow As Long
     Worksheets("Materials Summary").Activate
     On Error Resume Next
       lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    ActiveWorkbook.Worksheets("Materials Summary").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Materials Summary").Sort.SortFields.Add Key:=Range("A2:f" & lastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Materials Summary").Sort
        .SetRange Range("A:f" & lastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For x = lastRow To 2 Step -1
        If Cells(x, 2) = "" Or Cells(x, 2) = 0 Then
            Rows(x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = True
      End Sub
      Sub consolidatedata()
    Worksheets("Materials Summary").Range("h2").Consolidate _
    Sources:=Array("Materials Summary!data"), _
    Function:=xlSum, LeftColumn:=True
    Sheets("Overall Summary").Select
End Sub
6 - There is also a macro which copies the Builder Costings worksheet to the itemised detail worksheet and sorts through that particular data and deletes the rows that I need deleted (This is my problem code)
Code:
Sub delrowsifzero1()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim lastRow As Long
     Worksheets("Itemised Detail").Activate
     On Error Resume Next
       lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    ActiveWorkbook.Worksheets("Itemised Detail").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Itemised Detail").Sort.SortFields.Add Key:=Range("A:a" & lastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Itemised Detail").Sort
        .SetRange Range("A:a" & lastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For x = lastRow To 2 Step -1
        If Cells(x, 1) = "" Or Cells(x, 1) = 0 Then
            Rows(x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationAutomatic
    Application.CutCopyMode = False
7. I have hidden worksheets that need to be made visible then hidden again to ensure all the above macros work correctly as they contain data which is only relevant on a developer level not an end user level
Code:
       'Hide worksheets
    Worksheets("Overall Costs").Visible = xlSheetHidden
    Worksheets("Single Unit Pricing").Visible = xlSheetHidden
    Worksheets("Total Hours For All Units").Visible = xlSheetHidden
    Worksheets("Single Unit Hours").Visible = xlSheetHidden
      End Sub

I apologise I know it's probably really confusing and as I have stated I am not a programmer or developer but I have a bit of an understanding on how this works and have managed to hobble my way through and frankencoded my way to where I am now. I am just unsure how else I can speed up the bottleneck I'm experiencing. I have an idea of how I could speed it up but because I am not very literate with the code I am unsure of what how I can go about implementing it and that is why I am here. I am pretty good with taking the basics and making it work for my situation
 
Upvote 0

Forum statistics

Threads
1,224,818
Messages
6,181,152
Members
453,021
Latest member
Justyna P

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
Back
Top