Malicious Office (OLE) / .XLSX — malware analysis report

Static analysis result for SHA-256 c114bc011557c9f2…

MALICIOUS

Office (OLE) / .XLSX

295.5 KB Created: 2015-06-10 08:32:07 Authoring application: Microsoft Excel First seen: 2023-01-18
MD5: 9f063b11cdd3f8ef416eeaaa7b3dcab7 SHA-1: 247b1e4b8f21c1a4dd2617a8322fa47c62596221 SHA-256: c114bc011557c9f295b55e750fd0465e6affabcf1a7f6f2a69955d7aeb30b9af
98 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment

The critical heuristic firing for VBA macro-virus self-replication and AV tampering, along with the detection of Workbook_Open and Auto_Open macros, strongly indicates malicious intent. The VBA code, although truncated, likely contains logic to download and execute a secondary payload, as suggested by the presence of embedded URLs and the general nature of macro-based threats. The document body, appearing as a civil project schedule, serves as a lure for this malicious activity.

Heuristics 5

  • VBA macros detected medium 3 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • VBA macro-virus self-replication / AV tampering critical OLE_VBA_MACRO_VIRUS_REPLICATION
    VBA macro programmatically rewrites VBA project code through the VBE object model (CodeModule/VBComponents InsertLines/DeleteLines/AddFromString or OrganizerCopy) to copy itself into the global template and other open documents, and/or disables Office macro-virus protection (Options.VirusProtection = False). This is the defining behavior of the W97M document macro-virus family — self-replicating code with no benign document use, independent of any AV signature.
    Matched line in script
                .DeleteLines 1, .CountOfLines
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Workbook_Open of VBA Document ThisWorkbook"
  • Auto_Open macro low OLE_VBA_AUTO
    Auto_Open macro
    Matched line in script
    Sub Auto_Open()
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://www.bom.gov.au/qld/flood/seast.shtml In document text (OLE body)
    • http://www.ozgrid.com/VBA/delete-module.htmIn document text (OLE body)
    • https://onbmd.sharepoint.com/sites/t012761_tender/calculations/clarificationIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/longPropertiesIn document text (OLE body)
    • http://schemas.openxmlformats.org/officeDocument/2006/customXmlIn document text (OLE body)
    • http://schemas.microsoft.com/sharepoint/v3/contenttype/formsIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/contentTypeIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/properties/In document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/properties/metaAttributesIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/propertiesIn document text (OLE body)
    • http://www.w3.org/2001/XMLSchemaIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/documentManagement/typesIn document text (OLE body)
    • http://schemas.microsoft.com/office/infopath/2007/PartnerControlsIn document text (OLE body)
    • http://schemas.openxmlformats.org/package/2006/metadata/core-propertiesIn document text (OLE body)
    • http://www.w3.org/2001/XMLSchema-instanceIn document text (OLE body)
    • http://purl.org/dc/elements/1.1/In document text (OLE body)
    • http://purl.org/dc/terms/In document text (OLE body)
    • http://schemas.microsoft.com/internal/obdIn document text (OLE body)
    • http://dublincore.org/schemas/xmls/qdc/2003/04/02/dc.xsdIn document text (OLE body)
    • http://dublincore.org/schemas/xmls/qdc/2003/04/02/dcterms.xsdIn document text (OLE body)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 145097 bytes
SHA-256: 27bc964d21e1096b6007c22928080f3bf24e49f71769252e8a349b3c8e141041
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "VBCode"
'B+W Civil Project Schedule workbook
'------------------------------------
'Version Date    Description of change   Update by   Checked
'1.0 01-06-1994  Created by RG for Progress Claims   R.Gray
'1.31             Lotus format. MontyPk5B R.Gray
'1.32 12-08-1994  Lotus format    R.Gray  J.Bates/J.Jentz
'3.01 01-05-1995  Rewrite into Excel5 format VBA. PebbleBch Stg12 R.Gray  J.Bates
'3.1 16-12-1996  updates. PebbleBeach 14 R.Gray
'4.0 30-01-1997  major rewrite. Renumbering  P. Simpson  R.Gray
'5.0 20-08-1998      R. Gray
'5.1 20-08-1998      R. Gray
'5.1 11-02-1999  updated rates   S. Bates
'5.1 23-03-1999      R.Gray
'6.0 17-01-2002  Modified layout to show variation allowance R.Gray
'6.1 15-07-2002  Modified item decriptions and measures in line with Civil review group guidelines   R.Gray
'6.2 28-01-2005  About Page Added, Variations Page added. Macros Updated.    R.Gray
'6.3 14/01/2008  updated rates   N.Boundy    R.Gray
'6.4 11-Jun-2008  macros updated for ThisClaim columns. 'Issue' deleted VBA code.
'6.5 12-Jun-2008  added pdf output for XL2007.
'6.6 9.Oct.2012  RG  fixed some issues with macro for Past Claim.

'7.0 June.2105  RG.  rewrote MenuBar creation to new methods.
'                    made LastSchedule function, based upon position of Certificate to enable more sheets
'7.0a 11.June.2015 RG  added HowTo page to ensure text not lost. formatting poor
'------------------------------------
Option Explicit
Dim count_type As String
Function rainallow(day As Integer, rain As Single)
    'allow for the met bureau measuring to 9am
    'make day the previous day for purposes of calcing
    'rain allowance
    day = day - 1
    If day = 0 Then day = 7
        
    Select Case rain
        Case Is < 2.5
            rainallow = 0
        Case 2.4 To 5#
            If day < 7 Then
                'workday
                rainallow = 1
             Else
                rainallow = 0
            End If
        Case Is > 5
            If day < 6 Then
                'weekday allow 2
                rainallow = 2
             Else
                rainallow = 1
            End If
    End Select

        
End Function
Sub PrintPreview()
    PrintSelect "Preview"
End Sub
Sub PrintPDF()
    PrintSelect "PDF"
End Sub

Sub PrintSelect(ptype As String)
    Dim x As Boolean, ws As Worksheet, y As Boolean, newname As String
    Dim i As Integer, thisone As Worksheet
    HidePage "About", True
    'HidePage "EOT", True
    'HidePage "Certificate", True
    
    On Error GoTo skiphidden
    x = True: y = True
    For i = 2 To LastSchedule
        Set thisone = Worksheets(i)
        thisone.Select (x)
        If x And y Then
            'selected 1st sheet
            x = False
         Else
            y = True
        End If
    Next i
    
    Select Case ptype
        Case "Preview"
            ActiveWorkbook.PrintPreview
        Case "PDF"
            newname = ActiveWorkbook.Path & "\" & FileNameOnly(ActiveWorkbook.Name)
            newname = newname & "_" & Range("schedtype").Value
            'newname = Replace(newname, " ", "-")
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
               Filename:=newname, _
               Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                OpenAfterPublish:=True
        Case Else
            MsgBox "Unexpected Print Type in PrintSelect"
    End Select
    
    UndoSelection
  Exit Sub
skiphidden:
    y = False
    Resume Next
End Sub


Sub UndoSelection()
    On Error GoTo SkipHideSummary
    HidePage "About", False
    'HidePage "Certificate", False
    'HidePage "EOT", False
    
    Sheets(2).Select (True)
  Exit Sub
  
SkipHideSummary:
    Sheets(3).Select (True)
    Range("A1").Select

End Sub


Sub SetZoom()
    Dim i As Integer, thisone As Worksheet
    Application.StatusBar = "Setting print zoom ...."
    If CurrentSheetZoom = 0 Then
        'set default
        CurrentSheetZoom = zoom2
    End If
    Sheets("Summary").Activate
    Sheets("Summary").Select (True)
    For i = 3 To LastSchedule
        Set thisone = Worksheets(i)
        With thisone.PageSetup
            .Zoom = CurrentSheetZoom
        End With
        Sheets(Worksheets(i).Name).Select (False)
    Next i
    Application.StatusBar = False
End Sub


Sub DeleteEach(coltxt As String)
    Dim i As Integer, nm As String
    For i = 3 To LastSchedule
        nm = Worksheets(i).Name & "!" & coltxt
        Range(nm).EntireColumn.Delete
    Next i
End Sub

Sub DeleteSummary(col_txt As String)
    Range("Summary!" & col_txt).EntireColumn.Delete
End Sub
Sub Issue()
    Dim newname As String
    Dim i As Integer, j As Integer
    
    newname = ActiveWorkbook.Path & "\" & FileNameOnly(ActiveWorkbook.Name)
    newname = newname & "_issue"
    Application.DisplayAlerts = False
    'save as issue book
    ActiveWorkbook.SaveAs Filename:=newname, FileFormat:=xlOpenXMLWorkbook
         
    'show all columns
    Allcolumn
    
    'delete Not in Contract

    On Error GoTo skiptbhide
    For i = 3 To LastSchedule
        For j = ActiveWorkbook.Worksheets(i).Shapes.Count To 1 Step -1
            ActiveWorkbook.Worksheets(i).Shapes(j).Delete
        Next j
        ActiveWorkbook.Worksheets(i).Range("A1").Activate
    Next i
    
    'updated for CurrentClaim  11.Jun.08 NR/RG
    'rev7 delete the B+W sheets   13/Sept/2015  RRG
    DeleteEach "r1:v1"
    DeleteEach "h1:o1"
    
    DeleteSummary "i1:j1"
    DeleteSummary "d1:g1"
    Application.DisplayAlerts = False
    ActiveWorkbook.Worksheets("About").Delete
    ActiveWorkbook.Worksheets("Certificate").Delete
    ActiveWorkbook.Worksheets("EOT").Delete
    ActiveWorkbook.Worksheets("Comments").Delete
    ActiveWorkbook.Worksheets("HowTo").Delete

    Application.DisplayAlerts = True
    Range("schedtype").Value = "TENDER"
    UndoSelection
    ActiveWorkbook.Save
    
    'updated 11.Jun.08 RG
    
    'Sub DeleteThisModule()  http://www.ozgrid.com/VBA/delete-module.htm
    Dim vbCom As Object
         
    Set vbCom = Application.VBE.ActiveVBProject.VBComponents
    
    vbCom.Remove VBComponent:=vbCom.Item("VBCode")
    vbCom.Remove VBComponent:=vbCom.Item("menubar")
    'Sub DeleteWorkbookEventCode()
    ''Needs Reference Set To "Microsoft Visual Basic For Applications Extensibility"
    'Tools>References.
        
    With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
            .DeleteLines 1, .CountOfLines
    End With
    Application.DisplayAlerts = True
Exit Sub

skiptbhide:
    Application.DisplayAlerts = True
    Resume Next
    
End Sub
Function FileNameOnly(fnam As String) As String
    Dim i As Integer
    i = InStr(fnam, ".")
    If i > 0 Then
        FileNameOnly = Left(fnam, i - 1)
     Else
        FileNameOnly = "zzzz"
    End If
End Function
Sub Review()
    Dim newname As String
    Dim i As Integer, j As Integer
    Dim bDA As Boolean: bDA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    newname = ActiveWorkbook.Path & "\" & FileNameOnly(ActiveWorkbook.Name)
    newname = newname & "_review"
    'save as tender review workbook
    ActiveWorkbook.SaveAs Filename:=newname, FileFormat:=xlOpenXMLWorkbook
    
    'show all columns
    Allcolumn
    
    'delete Not in Contract

    On Error GoTo skiptbhide
    For i = 3 To LastSchedule
        For j = ActiveWorkbook.Worksheets(i).Shapes.Count To 1 Step -1
            ActiveWorkbook.Worksheets(i).Shapes(j).Delete
        Next j
    Next i
    
    For i = 3 To LastSchedule
        ActiveWorkbook.Worksheets(i).Activate
        Columns("H:I").Select
        Selection.Copy
        Range("J1:Q1").Select
        ActiveSheet.Paste
    
        Range("H3").Select
        ActiveCell.FormulaR1C1 = "TENDER1"
        Range("I3").Select
        ActiveCell.FormulaR1C1 = "TENDER1"
        Range("J3").Select
        ActiveCell.FormulaR1C1 = "TENDER2"
        Range("K3").Select
        ActiveCell.FormulaR1C1 = "TENDER2"
        Range("L3").Select
        ActiveCell.FormulaR1C1 = "TENDER3"
        Range("M3").Select
        ActiveCell.FormulaR1C1 = "TENDER3"
        Range("N3").Select
        ActiveCell.FormulaR1C1 = "TENDER4"
        Range("O3").Select
        ActiveCell.FormulaR1C1 = "TENDER4"
        Range("P3").Select
        ActiveCell.FormulaR1C1 = "TENDER5"
        Range("Q3").Select
        ActiveCell.FormulaR1C1 = "TENDER5"
    Next i
    
    'select the Summary Page
    ActiveWorkbook.Worksheets("Summary").Activate
    'select the tender colum. refers to col I of schedules
    Range("D18:D35").Select
    Application.CutCopyMode = False
    'move tender to left
    ActiveCell.Offset(0, 1).Range("A1:A20").Cut Destination:=ActiveCell.Range( _
        "A1:A20")
    'select & copy  start column
    ActiveCell.Range("A1:A20").Select
    
    'repeat 4 times
    For i = 2 To 5
        Selection.Copy
        'paste offset 2 columns
        ActiveCell.Offset(0, 2).Range("A1").Select
        ActiveSheet.Paste
        ActiveCell.Range("A1:A20").Select
        Application.CutCopyMode = False
        Selection.Cut Destination:=ActiveCell.Offset(0, -1).Range("A1:A20")
        ActiveCell.Offset(0, -1).Range("A1:A20").Select
    Next i
    'move up 2 rows to titles
    ActiveCell.Offset(-2, 0).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Tender5"
    ActiveCell.Offset(0, -1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Tender4"
    ActiveCell.Offset(0, -1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Tender3"
    ActiveCell.Offset(0, -1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Tender2"
    ActiveCell.Offset(0, -1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Tender1"
    ActiveCell.Offset(1, -3).Range("A1").Select

    Application.DisplayAlerts = True
    Range("schedtype").Value = "TENDER_REVIEW"
    UndoSelection
    ActiveWorkbook.Save
    Application.DisplayAlerts = bDA
    Exit Sub

skiptbhide:
    Application.DisplayAlerts = True
    Resume Next
    
End Sub
Sub Hide_all()
    Dim nm As String, sch As Variant
    Dim i As Integer
    HideSummary "d1:j1", True
    HideEach "g1:v1", True
    'HidePage "About", True
    HideNotInContract True
    HideQuantComment True
    HidePage "Certificate", True
    HidePage "EOT", True
    HidePage "Summary", False
    For i = LastSchedule To ActiveWorkbook.Sheets.Count
        
    Next i
End Sub

Sub HideSummary(sht As String, hideit As Boolean)
    Range("Summary!" & sht).EntireColumn.Hidden = hideit
End Sub
Sub HidePage(pagename$, hideit As Boolean)
    Worksheets(pagename$).Visible = Not hideit
End Sub


Sub HideEach(sht As String, hideit)
    
    Dim i As Integer, nm As String

    For i = 3 To LastSchedule  'Worksheets.Count - 2
        nm = Worksheets(i).Name & "!" & sht
        Range(nm).EntireColumn.Hidden = hideit
    Next i
End Sub

Function LastSchedule() As Integer
    Dim wstmp As Worksheet
    Set wstmp = ActiveWorkbook.Sheets("Certificate")
    
    LastSchedule = wstmp.Index - 1
End Function

Sub HideNotInContract(hideit)
    Dim i As Integer, j As Integer
    On Error GoTo skiptbhide
    For i = 3 To LastSchedule
        For j = 1 To ActiveWorkbook.Worksheets(i).Shapes.Count
            ActiveWorkbook.Worksheets(i).Shapes(j).Visible = Not (hideit)
        Next j
    Next i
    
    Exit Sub
skiptbhide:
    Resume Next
End Sub
Sub HideQuantComment(hideit)
    Dim i As Integer, j As Integer
    On Error GoTo skiptbhide
    i = 1
    For j = 1 To ActiveWorkbook.Worksheets(i).Shapes.Count
            ActiveWorkbook.Worksheets(i).Shapes(j).Visible = Not (hideit)
    Next j

 
    Exit Sub
skiptbhide:
    Resume Next
End Sub


Sub ProgressPay()
    Hide_all
    HidePage "EOT", False
    HidePage "Certificate", False
    
    HidePage "summary", False
    HideSummary "e1:f1", False
    HidePage "Variations", False
    
    HideEach "g1:k1", False
    
    If Range("ShowPrev").Value = True Then
        HideSummary "j1:j1", False
        HideEach "l1:m1", False
    End If
    HideNotInContract True
    HideQuantComment False
    Bond_unhide
    'Range("schedtype").Value = "PROGRESS CLAIM #x"
    Range("schedtype").Formula = "=" & Chr(34) & "PROGRESS CLAIM #" & Chr(34) & "& claim_number"
    UndoSelection
End Sub

Sub Certificate()
    Hide_all
    
    ProgressPay  'set rest of sheets as progress payment
    HidePage "EOT", False
    HidePage "Certificate", False

    
    HidePage "summary", False
    
    
    Sheets("EOT").Select (True)
    Range("A1").Select
    Sheets("Certificate").Select (True)
    Range("A1").Select
    
    
    'UndoSelection
End Sub

Sub Bond()
    Hide_all
    HidePage "summary", False
    HideSummary "e1:e1", False
    HideSummary "g1:g1", False
    HidePage "Variations", False
    HideEach "g1:i1", False
    HideEach "r1:s1", False
    HideNotInContract True
    HideQuantComment True
    Bond_unhide
    Range("schedtype").Value = "UNCOMPLETED WORKS"
    UndoSelection
End Sub

Sub Allcolumn()
    HideSummary "d1:j1", False
    HidePage "summary", False
    HidePage "About", False
    HidePage "Variations", False
    HidePage "Certificate", False
    HidePage "EOT", False
    
    HideEach "g1:v1", False
    HideNotInContract False
    HideQuantComment False
    Bond_unhide
    Range("schedtype").Value = "ALL DISPLAYED"
    UndoSelection
End Sub

Sub Estimated()
    Hide_all
    HidePage "summary", False
    HideSummary "d1:d1", False
    HideSummary "i1:i1", False
    HidePage "Variations", False
    HideEach "n1:o1", False
    HideEach "g1:g1", False
    'HideNotInContract True
    HideQuantComment False
    Bond_unhide
    Range("schedtype").Value = "ESTIMATE"
    UndoSelection
End Sub

Sub Quantities()
    Hide_all
    HidePage "summary", False
    HidePage "EOT", True
    HidePage "Certificate", True
    HidePage "Variations", True
    HideEach "g1:g1", False
    HideEach "u1:u1", False
    HideNotInContract False
    Bond_unhide
    HidePage "summary", True
    Range("schedtype").Value = "ESTIMATED QUANTITIES"
    UndoSelection
End Sub

Sub Tendered()
    Hide_all
    HidePage "summary", False
    HideSummary "e1:e1", False
    HideSummary "i1:i1", False
    HideEach "h1:i1", False
    HideEach "t1:t1", False
    HideNotInContract True
    HideQuantComment True
    Bond_unhide
    Range("schedtype").Value = "TENDER RATES AND AMOUNTS"
    UndoSelection
End Sub

Sub Rates_amounts()
    Hide_all
    HidePage "summary", False

    HideSummary "h1:i1", False
    'HideEach "e1:f1", False
    HideEach "p1:q1", False
    HideNotInContract True
    HideQuantComment True
    Bond_unhide
    Range("schedtype").Value = "RATES AND AMOUNTS"
    UndoSelection
End Sub

Sub Unit_metre()
    Range("metre").Copy
    ActiveCell.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Select
End Sub

Sub Unit_metre2()
    Range("metre2").Copy
    ActiveCell.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Select
End Sub

Sub Unit_metre3()
    Range("metre3").Copy
    ActiveCell.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Select
End Sub

Sub Unit_item()
    Range("item").Copy
    ActiveCell.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Select
End Sub

Sub Unit_each()
    Range("each").Copy
    ActiveCell.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Select
End Sub

Sub Unit_tonne()
    Range("tonne").Copy
    ActiveCell.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Select
End Sub

Sub Unit_PCItem()
    Range("PCItem").Copy
    ActiveCell.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Select
End Sub

Sub StdPageSetup()
    Dim i As Integer, thisone As Worksheet
    Application.StatusBar = "Executing page setup. Please wait ...."
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
    Set thisone = Worksheets(2)
    With thisone.PageSetup
        .PrintTitleRows = "$1:$4"
        .PrintTitleColumns = ""
        'thisone.PageSetup.PrintArea = ""
    
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = "&8&F"
        .CenterFooter = "&10Page &P of &N"
        .RightFooter = "&8&D"
        .LeftMargin = Application.CentimetersToPoints(2)
        .RightMargin = Application.CentimetersToPoints(1.2)
        .TopMargin = Application.CentimetersToPoints(1.5)
        .BottomMargin = Application.CentimetersToPoints(1.01)
        .HeaderMargin = Application.CentimetersToPoints(0.1)
        .FooterMargin = Application.CentimetersToPoints(0.6)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintNotes = False
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = True
        .FitToPagesWide = 1
        .FitToPagesTall = 99
        
    End With
    For i = 3 To LastSchedule
        Worksheets(i).PageSetup = Worksheets(2).PageSetup
        
    Next i
    Application.Calculation = xlAutomatic
    Application.Calculate
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Sub SetColumnWidth()
    Dim i As Integer
    Dim rCurrent As Range, wsCurr As Worksheet
    Set wsCurr = ActiveSheet: Set rCurrent = ActiveCell
    
    Application.StatusBar = "Executing column setup. Please wait ...."
    Application.ScreenUpdating = False
    For i = 3 To LastSchedule
        Sheets(Worksheets(i).Name).Activate
        Range("a1").ColumnWidth = 4.5
        Range("b1,c1").ColumnWidth = 1
        Range("d1").ColumnWidth = 1.1
        Range("e1").ColumnWidth = 45
        Range("f1,g1").ColumnWidth = 6         'unit and qty
        Range("h1,j1,l1,n1,u1,p1").ColumnWidth = 8   'rate
        Range("i1,k1,m1,o1,t1").ColumnWidth = 11     'amount
        Range("u1").ColumnWidth = 9.5  'end
        Range("w1").ColumnWidth = 1.3  'end
    Next i
    wsCurr.Activate: rCurrent.Parent.Activate: rCurrent.Activate
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Sub Bond_hide()
    Dim i As Integer
    Dim foundcell As Range, search_area As Range, sa As Range
    Dim check As Range
    Application.StatusBar = "Executing Bond Hide. Please wait ...."
    UndoSelection
    For i = 3 To LastSchedule
        Sheets(Worksheets(i).Name).Select (True)
        Sheets(Worksheets(i).Name).Activate
        Range("A1").Activate
        Set search_area = Selection
        Do
            Set search_area = Range(ActiveCell, ActiveCell.SpecialCells(xlLastCell))
            Set foundcell = search_area.Find(What:="bond n/a", After:=ActiveCell, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext _
                , MatchCase:=False)
            
            If foundcell Is Nothing Then
                    'exit out
            Else
                foundcell.Activate
                Set check = foundcell.Offset(1, -12)    '12 is offset for description column
                If IsEmpty(check.Value) Then
                    Set check = foundcell.Offset(1, -9)    '9 is offset for header check
                    If IsEmpty(check.Value) Then
                        Range(foundcell, Selection.Offset(1, 0)).Select
                        Selection.EntireRow.Hidden = True
                    Else
                        Selection.EntireRow.Hidden = True
                    End If
                Else
                        Selection.EntireRow.Hidden = True
                End If
                    Selection.Offset(1, -1).Select
            End If
                
        Loop Until foundcell Is Nothing
        Range("A1").Select
    Next i
    UndoSelection
    Application.StatusBar = False
End Sub

Sub Bond_unhide()
    Dim i As Integer
    On Error Resume Next
    For i = 3 To LastSchedule
        Sheets(Worksheets(i).Name).Select (True)
        Sheets(Worksheets(i).Name).Activate
        Range("A1").Select
        Cells.Select
        Selection.EntireRow.Hidden = False
        Range("A1").Select
    Next i
    UndoSelection
End Sub

Sub Bond_insert()
    Dim x As Integer
    x = ActiveCell.Row
    Application.Cells(x, 19).Value = "bond n/a"     '19 is for Bond Amount column
End Sub

Sub Renumber()
    Dim i As Integer, counta As Integer, countb As Integer, countc As Integer, _
    countd As Integer, position As Integer, final As Integer
    Dim founditem As Range, search_area As Range, sa As Range, checka As Range _
        , checkb As Range, checkc As Range, checkd As Range
    Dim response As Variant
    Application.StatusBar = "Executing Item Renumber. Please wait ...."
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    response = MsgBox("Make sure you save your file before running this macro!  Do you wish to continue? (Task will take max. 15 seconds to complete)", _
             vbYesNo + vbCritical + vbDefaultButton2, "Warning!")
    
    If count_type = "" Then count_type = "numeric"
    
    If response = vbYes Then           'User chose Yes button
        UndoSelection    'runs sub-macro
         'each worksheet loop
        For i = 3 To LastSchedule - 1        'dont renumber Variations or Certif or EOT
            Sheets(Worksheets(i).Name).Select (True)
            Sheets(Worksheets(i).Name).Activate
            Range("A1").Activate
            Set search_area = Range(ActiveCell, ActiveCell.SpecialCells(xlLastCell))
            Set founditem = search_area.Find(What:="item", After:=ActiveCell, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
                , MatchCase:=False)  'find first page header heading
                        
            founditem.Activate                         'activate heading cell containing item
            Selection.Offset(2, 0).Activate            'go to first number cell in col A
            counta = 0                                      'zero column A counter
            countb = 0                                      'zero column B counter
            countc = 1                                      'zero column C counter to 1
            countd = 0                                      'zero column D counter
            position = ActiveCell.Row                       'value of current row number
            final = ActiveCell.SpecialCells(xlLastCell).Row 'value of final row on sheet
            Do While position < final                       'while not the end of the sheet
                Set checka = Selection                      'set col A check to current cell
                If IsEmpty(checka.Value) Then               'check col A cell contents
                    Selection.Offset(0, 1).Activate         'if col A empty move to col B
                    Set checkb = Selection                  'set col B check to current cell
                    If IsEmpty(checkb.Value) Then           'check col B cell contents
                        Selection.Offset(0, 1).Activate     'if col B empty move to col C
                        Set checkc = Selection              'set col C check to current cell
                        If IsEmpty(checkc.Value) Then       'check col C cell contents
                            Selection.Offset(0, 1).Activate 'if col C empty move to col D
                            Set checkd = Selection          'set col D check to current cell
                            If IsEmpty(checkd.Value) Then   'check col D cell contents
                                Selection.Offset(1, -3).Activate 'if empty move back to col A
                            Else                            'column D is non-empty
                                If Selection.EntireRow.Hidden = True Then 'row is hidden, skip it
                                    Selection.Offset(1, -3).Activate  'and go to col A
                                Else
                                    Selection.Value = GetCount("d", counta, countb, countc, countd)
                                    'Selection.Value = Chr(97 + countd) & ")" 'code 97 for a
                                    Selection.Offset(1, -3).Activate    'go to col A
                                    'countd = countd + 1          'increment column D counter
                                End If
                            End If                          'end column D check
                        Else                                'column C is non-empty
                            If Selection.EntireRow.Hidden = True Then   'row is hidden, skip it
                                Selection.Offset(1, -2).Activate        'and go to col A
                            Else
                                Selection.Value = GetCount("c", counta, countb, countc, countd)
                                'Selection.Value = "(" & CStr(countc) & ")"  'enter col C value
                                Selection.Offset(1, -2).Activate    'go to col A
                                'countc = countc + 1               'increment column C counter
                                'countd = 0   'reset column D counter when column C value is found
                            End If
                        End If                              'end column C check
                    Else                                    'column B is non-empty
                        If Selection.EntireRow.Hidden = True Then       'row is hidden, skip it
                            Selection.Offset(1, -1).Activate            'and go to col A
                        Else
                            If ActiveCell.Value = "         DESCRIPTION" Then    'check contents
                                Selection.Offset(1, -1).Activate   'if yes, skip and go to col A
                            Else
                                Selection.Value = GetCount("b", counta, countb, countc, countd)
                                'Selection.Value = "(" & Chr(97 + countb) & ")"    'code 97 for a
                                Selection.Offset(1, -1).Activate    'go to col A
                                'countb = countb + 1               'increment column B counter
                                'countc = 1    'reset column C counter when column B value is found
                            End If
                        End If
                    End If                                  'end column B check
                Else                                        'col A is non empty
                    If ActiveCell.Value = "ITEM" Then       'check for header
                        Selection.Offset(1, 0).Activate     'if yes, skip and go to col A
                    Else
                        Selection.Value = GetCount("a", counta, countb, countc, countd)
                        'Selection.Value = (1 + counta)       'enter column A value
                        Selection.Offset(1, 0).Activate      'move down one row
                        'counta = counta + 1                  'increment col A counter
                        'countb = 0            'reset column B counter when column A value is found
                    End If
                End If
                position = ActiveCell.Row     'change row position value to current value
            Loop                                'Loop till end of sheet
            Range("A1").Select               'at end of sheet renumbering, move to home cell
        
        Next i                                  'move to next page
    Else
        'exit out if response=vbno
    End If
    Application.Calculation = xlAutomatic
    Application.StatusBar = False
    Application.ScreenUpdating = True
    UndoSelection                              'run sub-macro
End Sub

Function GetCount(col As String, counta As Integer, countb As Integer, countc As Integer, countd As Integer)
        
        Select Case col
            Case "a"
                counta = counta + 1
                countb = 0: countc = 0: countd = 0
            Case "b"
                countb = countb + 1
                countc = 0: countd = 0
            Case "c"
                countc = countc + 1
                countd = 0
            Case "d"
                countd = countd + 1
        End Select

    Select Case count_type
        Case "numeric"
            GetCount = Format(counta, "'##.")
            GetCount = GetCount & Format(countb, "##0;;\ ")
            GetCount = GetCount & Format(countc, "\.##0;;\ ")
            GetCount = GetCount & Format(countd, "\.##0;;\ ")
        Case Else
            'std
            Select Case col
                Case "a"
                    GetCount = Format(counta, "##0.0")     'enter column A value
                Case "b"
                    GetCount = "(" & Chr(96 + countb) & ")"    'code 97 for a
                Case "c"
                    GetCount = "(" & CStr(countc) & ")" 'enter col C value
                Case "d"
                    GetCount = Chr(96 + countd) & ")" 'code 97 for a
            End Select
        End Select

End Function

Sub renum_std()
    count_type = "std"
End Sub
Sub renum_num()
    count_type = "numeric"
End Sub

Private Function Sheetname(x As Range)
    Sheetname = x.Worksheet.Name
End Function
Function stringctr(x As String, width As Integer)
    stringctr = x & Space((width - Len(x)) / 2)
End Function



Sub Auto_Open()
    'use to update ProgressClaims
    Dim x As Integer, msg$
    
    If Left(Range("schedtype").Value, 14) = "PROGRESS CLAIM" Then
        msg$ = "This schedule is currently a Progress Claim type." & vbCrLf & vbCrLf
        msg$ = msg$ & "Do you wish to begin processing a new claim ?" & vbCrLf & vbCrLf
        msg$ = msg$ & "i.e. Increase the claim number by one and " & vbCrLf & "update the value of work previously certified"
        x = MsgBox(msg$, vbYesNo + vbQuestion + vbDefaultButton2, "New Progress Claim")
        If x = vbYes Then
            'update
            UpdateClaim
        End If
    End If
End Sub

Sub UpdateClaim()
    Dim s As String, cln As Integer
    Dim cert_prev As Currency, cert_prevtot As Currency, cert_tot As Currency
    
    'get current data
    cln = Range("claim_number").Value
    
    cert_prev = Range("claim_tot")
    cert_prevtot = Range("claim_prevtot")
    
    'update data
    cln = cln + 1
    'Range("schedtype").Value = "PROGRESS CLAIM #" & Format(cln, "#0")
    Range("claim_number").Value = cln
    
    cert_tot = cert_prevtot + cert_prev
    Range("claim_prevtot") = cert_tot
    
    UpdatePreviousClaim
    
End Sub

Sub UpdatePreviousClaim()
    Dim i As Integer
    Dim foundcell As Range, search_area As Range
    Dim lastrow As Integer
    
    Application.StatusBar = "Updating Previous claim values Please wait ...."
    UndoSelection
    For i = 3 To LastSchedule
        Sheets(Worksheets(i).Name).Activate
        
        
        Range("A1").Activate
        Set search_area = Selection
        Set search_area = Range(ActiveCell, ActiveCell.SpecialCells(xlLastCell))
        Set foundcell = search_area.Find(What:="Past", After:=ActiveCell, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext _
            , MatchCase:=False)
        
        If foundcell Is Nothing Then
                'exit out
                MsgBox "Cant find 'Past' header" & vbCrLf & Worksheets(i).Name, vbCritical + vbOKOnly, "error in Update Prev"
                Stop
        Else
            'fix 6.6
            foundcell.Activate
            If LCase$(foundcell.Offset(1, 0).Value) <> "amount" Then
                MsgBox "Cant find 'Past Claim' header", , "error in Update Prev"
                Stop
            End If
            
            lastrow = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count
            Range(foundcell.Offset(2, -1), foundcell.Offset(lastrow + 20, -1)).Copy
            foundcell.Offset(2, 0).PasteSpecial xlPasteValues
         
        End If
            
        Range("A1").Select
    Next i
    UndoSelection
    Application.StatusBar = False


End Sub
Sub ReviewSummary()


'
    Range("E18:E35").Select
    Application.CutCopyMode = False
    ActiveCell.Offset(0, 1).Range("A1:A18").Cut Destination:=ActiveCell.Range( _
        "A1:A18")
    ActiveCell.Range("A1:A18").Select
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Range("A1:A18").Select
    Application.CutCopyMode = False
    Selection.Cut Destination:=ActiveCell.Offset(0, -1).Range("A1:A18")
    ActiveCell.Offset(0, -1).Range("A1:A18").Select
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Range("A1:A18").Select
    Application.CutCopyMode = False
    Selection.Cut Destination:=ActiveCell.Offset(0, -1).Range("A1:A18")
    ActiveCell.Offset(0, -1).Range("A1:A18").Select
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Cut Destination:=ActiveCell.Offset(0, -1).Range("A1:A18")
    ActiveCell.Offset(0, -1).Range("A1:A18").Select
    Selection.Copy
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Cut Destination:=ActiveCell.Offset(0, -1).Range("A1:A18")
    ActiveCell.Offset(0, -1).Range("A1:A18").Select


End Sub



Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
…

Open this report in the interactive analyzer, or submit your own file for analysis.