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

Static analysis result for SHA-256 655cf04cff2f4ab5…

MALICIOUS

Office (OLE) / .XLS

144.5 KB Created: 2003-12-12 16:09:51 Authoring application: Microsoft Excel First seen: 2026-05-10
MD5: 36a7677723ecdf54c10928cc4ced8af9 SHA-1: ba17a4617c90e862968636d06ad557b18aebc2b7 SHA-256: 655cf04cff2f4ab5a7a7ea905dd986bf37e2abd1fc7f114ebfebeaf3244ddef7
130 Risk Score

Malware Insights

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

The sample is an Excel file containing a Workbook_Open VBA macro that executes a Format subroutine. This subroutine utilizes CreateObject, indicating potential malicious activity such as downloading and executing further stages. The macro also exhibits self-replication behavior, a common characteristic of malware. While the document body appears to be a price list, the presence of these advanced macro features strongly suggests a malicious intent, likely to deliver a secondary payload.

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
        ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule.DeleteLines 1, iLines
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set oFSO = CreateObject("Scripting.FileSystemObject")
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_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://ocsp.verisign.com0 In document text (OLE body)
    • https://www.verisign.com/rpaIn document text (OLE body)
    • https://www.verisign.com/rpa01In document text (OLE body)
    • http://crl.verisign.com/pca3.crl0In document text (OLE body)
    • http://CSC3-2004-crl.verisign.com/CSC3-2004.crl0DIn document text (OLE body)
    • https://www.verisign.com/rpa0In document text (OLE body)
    • http://CSC3-2004-aia.verisign.com/CSC3-2004-aia.cer0In document text (OLE body)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas🔏 SignedVBA project digital signature
Covers VBA source only — not the compiled p-code. A digital signature does not by itself mean the macro is safe.		 vba-macro oletools.olevba.extract_macros (decoded VBA source) 35577 bytes
SHA-256: 5735744afea68540ed2253cc7aa2cf705e9fcd3f22655db1bd2a61c7346bcd41
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Private Sub Workbook_Open()
    Format
End Sub

Sub Format()
    
    'Delete the first two rows
    CreateWaitMessage
    
    CheckAnyWorkBookIsOpen
    
    Application.ScreenUpdating = False
    Worksheets("Header").Range("A2:A2").Value = Range("BA2:BA2").Value
    Worksheets("Header").Range("B2:B2").Value = Range("BB2:BB2").Value
    Worksheets("Header").Range("C2:C2").Value = Range("BC2:BC2").Value
    Worksheets("Header").Range("D2:D2").Value = Range("BD2:BD2").Value
    Worksheets("Header").Range("E2:E2").Value = Range("BE2:BE2").Value
    Worksheets("Header").Range("F2:F2").Value = Range("BF2:BF2").Value
    Worksheets("Header").Range("G2:G2").Value = Range("BG2:BG2").Value
    Worksheets("Header").Range("H2:H2").Value = Range("BH2:BH2").Value
    Worksheets("Header").Range("I2:I2").Value = Range("BI2:BI2").Value
    Worksheets("Header").Range("J2:J2").Value = Range("BJ2:BJ2").Value
    Worksheets("Header").Range("K2:K2").Value = Range("BK2:BK2").Value
    Worksheets("Header").Range("L2:L2").Value = Range("BL2:BL2").Value
    Range("B1:B3").EntireRow.Delete
    
    CreateTitle
    RemoveDuplicateFamilyDesc
    RemoveDuplicateSectionDesc
    AlignPriceFields
    CreateSectionHeaders
    
    'Clear SecDesc column
    Columns("X:X").ClearContents
    
    'SetFontSize
   
    ShowNewItems
    ShowDecreasePriceItems
    ShowIncreasePriceItems
    
    'Delete the unwanted columns first
    DeleteUnwantedColumns
    
    'Now delete Formatinfo sheet
    Application.DisplayAlerts = False
    Sheets("FormatInfo").Delete
    Sheets("Header").Delete
    Application.DisplayAlerts = True
    
    
    'Wrap family desc
    Columns("B:B").Select
    Selection.WrapText = True
    
    'Freeze
    Rows("2:2").Select
    Selection.Interior.ColorIndex = xlNone
    Rows("2:2").RowHeight = 12.75
    Range("E2").Select
    ActiveWindow.FreezePanes = True
    
    'Set font size
    Range("A2:AD2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 11
   
    'Postioning
    Sheets(1).Select
    Range("C2").Select
    ActiveWindow.Zoom = 75
    ActiveWindow.FreezePanes = False 'IM2230729 - Macro does not unfreeze the first 4 rows
    DeleteWaitMessage
    
    SaveAsFormattedFile
    
    PutTitleBorders
    
    'Now delete all the code in macro
    DeleteMacro
    
End Sub
Private Sub AlignPriceFields()
    Range("H:H,K:K,N:N,Q:Q,T:T,W:W").Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
End Sub

Private Sub PutTitleBorders()
    'For title
    Range("A1:E1").Borders(xlDiagonalDown).LineStyle = xlNone
    Range("A1:E1").Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("A1:E1").Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range("A1:E1").Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range("A1:E1").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range("A1:E1").Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A1:E1").Borders(xlInsideVertical).LineStyle = xlNone
End Sub
Private Sub SaveAsFormattedFile()
    
    Dim sFileName As String
    Dim oFSO As Object
    Dim oFile As Object
    
    sFileName = ActiveWorkbook.FullName
    sFileName = Replace(sFileName, "_unformatted", "")

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If oFSO.FileExists(sFileName) = True Then
        Set oFile = oFSO.GetFile(sFileName)
        oFile.Delete
    End If
    ActiveWorkbook.SaveAs sFileName, xlNormal, "", "", False, False
    
    
End Sub
Private Sub DeleteUnwantedColumns()
    Dim rRange As Range
    Dim iRowCnt As Integer
    Dim iColCnt As Integer
    Dim sRange As String
    
    iRowCnt = Sheet1.UsedRange.Rows.Count
    iColCnt = Sheet1.UsedRange.Columns.Count

    
    Set rRange = Worksheets(1).Range(Cells(1, 1), Cells(iRowCnt, iColCnt))
    With rRange
        Set c = .Find("###XXXXX###", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                
                c.Select
                c.Value = ""
                sRange = sRange + c.Address + ", "
                
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    If sRange <> "" Then
        sRange = Left(sRange, Len(sRange) - 2)
        Set rRange = Range(sRange)
        rRange.Select
        rRange.EntireColumn.Delete
    End If

End Sub

Private Sub DeleteMacro()

    'Delete this macro
    Dim iLines As Integer
    iLines = ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule.CountOfLines
    ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule.DeleteLines 1, iLines
    ThisWorkbook.Save

End Sub

Private Sub ShowIncreasePriceItems()
    With Worksheets(1).Range("A1:A65535")
        Set c = .Find("U", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A1:A1").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("F1:F65535")
        Set c = .Find("U", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A1:A1").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("I1:I65535")
        Set c = .Find("U", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A1:A1").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("L1:L65535")
        Set c = .Find("U", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A1:A1").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("O1:O65535")
        Set c = .Find("U", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A1:A1").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("R1:R65535")
        Set c = .Find("U", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A1:A1").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("U1:U65535")
        Set c = .Find("U", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A1:A1").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
End Sub
Private Sub ShowDecreasePriceItems()
    With Worksheets(1).Range("A1:A65535")
        Set c = .Find("D", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A2:A2").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("F1:F65535")
        Set c = .Find("D", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A2:A2").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("I1:I65535")
        Set c = .Find("D", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A2:A2").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("L1:L65535")
        Set c = .Find("D", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A2:A2").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("O1:O65535")
        Set c = .Find("D", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A2:A2").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("R1:R65535")
        Set c = .Find("D", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A2:A2").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("U1:U65535")
        Set c = .Find("D", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A2:A2").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
End Sub
Private Sub ShowNewItems()
    With Worksheets(1).Range("A1:A65535")
        Set c = .Find("N", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A3:A3").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("F1:F65535")
        Set c = .Find("N", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A3:A3").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("I1:I65535")
        Set c = .Find("N", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A3:A3").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("L1:L65535")
        Set c = .Find("N", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A3:A3").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("O1:O65535")
        Set c = .Find("N", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A3:A3").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("R1:R65535")
        Set c = .Find("N", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A3:A3").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    With Worksheets(1).Range("U1:U65535")
        Set c = .Find("N", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = Worksheets(2).Range("A3:A3").Value
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
End Sub
Private Sub SetFontSize()
    Range("A3:A49").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    With Selection.Font
        .Name = "Arial"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("A1:E1").Select
End Sub
Private Sub CreateTitle()
    
    'Application.CutCopyMode = False
    Range("A1").EntireRow.Insert
    Cells(1, 1).Value = Cells(3, 25).Value
    
    With Range("A1:E1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:E1").Merge
    With Range("A1:E1").Font
        .Name = "Arial"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With Range("A1:E1")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Range("A1:E1").Interior
        .ColorIndex = 40
        .Pattern = xlSolid
    End With
    
    'Delete column containins Header details
    Range("Y1").EntireColumn.Delete

End Sub

Private Sub RemoveDuplicateFamilyDesc()
    'Loop thru the column 2 and remove duplicate items
    Dim iRowCnt As Integer
    Dim sFamilyDesc As String
    Dim sCurrentFamilyDesc As String
    Dim sPrevFamilyDesc As String
    
    iRowCnt = 2
    sCurFamilyDesc = "X"
    sPrevFamilyDesc = "Y"
    
    For iRowCnt = 2 To Sheet1.UsedRange.Rows.Count
        sCurFamilyDesc = Cells(iRowCnt, 2)
        If sCurFamilyDesc <> sPrevFamilyDesc Then
            sPrevFamilyDesc = Cells(iRowCnt, 2)
        Else
            Cells(iRowCnt, 2) = ""
            Cells(iRowCnt, 1) = ""
        End If
    Next

End Sub
Private Sub RemoveDuplicateSectionDesc()
    
    'Loop thru the column 2 and remove duplicate items
    Dim iRowCnt As Integer
    Dim sCurrentSectionDesc As String
    Dim sPrevSectionDesc As String
    
    sCurrentSectionDesc = "X"
    sPrevSectionDesc = "Y"
    
    For iRowCnt = 2 To (Sheet1.UsedRange.Rows.Count - 1)
        sCurrentSectionDesc = Cells(iRowCnt, 24)
        If sCurrentSectionDesc <> sPrevSectionDesc Then
            sPrevSectionDesc = Cells(iRowCnt, 24)
            Cells(iRowCnt, 25).Value = "H"
        Else
            Cells(iRowCnt, 24) = ""
        End If
    Next

End Sub
Private Sub putBorder(ByVal rRange As Range)


    rRange.Borders(xlDiagonalDown).LineStyle = xlNone
    rRange.Borders(xlDiagonalUp).LineStyle = xlNone
    With rRange.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rRange.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rRange.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With rRange.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    rRange.Borders(xlInsideHorizontal).LineStyle = xlNone
    
End Sub

Private Sub CreateSectionHeaders()

    Dim rRange As Range
    Set rRange = Range(Cells(1, 25), Cells(Sheet1.UsedRange.Rows.Count, 25))
    
    With rRange
        Set c = .Find("H", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = ""
                c.EntireRow.Insert
                c.EntireRow.Insert
                c.EntireRow.Insert
                c.EntireRow.Insert
                
                Cells(c.Row - 3, 1).Interior.ColorIndex = 36
                
                Cells(c.Row - 3, 2).Value = Cells(c.Row, 24).Value     'Family Desc
                Cells(c.Row - 3, 2).Interior.ColorIndex = 35
                Cells(c.Row - 3, 2).Font.Bold = True
                Cells(c.Row - 3, 2).Font.Size = 10
                putBorder Range(Cells(c.Row - 3, 2), Cells(c.Row - 3, 2))
                
                Cells(c.Row - 3, 3).Value = Worksheets("Header").Range("B2:B2").Value '"Warranty Code(s)"
                Cells(c.Row - 3, 3).Interior.ColorIndex = 36
                Cells(c.Row - 3, 3).Font.Bold = True
                Cells(c.Row - 3, 3).Font.Size = 10
                With Cells(c.Row - 3, 3)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = True
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                .ColumnWidth = 10.57
                End With
                
                
                Cells(c.Row - 3, 4).Value = Worksheets("Header").Range("C2:C2").Value '"SPL"
                Cells(c.Row - 3, 4).Interior.ColorIndex = 36
                Cells(c.Row - 3, 4).Font.Bold = True
                Cells(c.Row - 3, 4).Font.Size = 10
                
                Cells(c.Row - 3, 5).Value = Worksheets("Header").Range("D2:D2").Value '"Service Description"
                Cells(c.Row - 3, 5).Interior.ColorIndex = 36
                Cells(c.Row - 3, 5).Font.Bold = True
                Cells(c.Row - 3, 5).Font.Size = 10
                
                'Cells(c.Row - 3, 6).Value = ""
                Cells(c.Row - 3, 6).Interior.ColorIndex = 36
                
                Cells(c.Row - 3, 7).Value = Worksheets("Header").Range("E2:E2").Value '"1 Year"
                Cells(c.Row - 3, 7).Interior.ColorIndex = 36
                Cells(c.Row - 3, 7).Font.Bold = True
                With Cells(c.Row - 3, 7)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
                
                'Cells(c.Row - 3, 8).Value = ""
                
                'Cells(c.Row - 3, 9).Value = ""
                Cells(c.Row - 3, 9).Interior.ColorIndex = 36
                
                Cells(c.Row - 3, 10).Value = Worksheets("Header").Range("F2:F2").Value '"2 Years"
                Cells(c.Row - 3, 10).Interior.ColorIndex = 36
                Cells(c.Row - 3, 10).Font.Bold = True
                With Cells(c.Row - 3, 10)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
                
                'Cells(c.Row - 3, 11).Value = ""
                'Cells(c.Row - 3, 12).Value = ""
                Cells(c.Row - 3, 12).Interior.ColorIndex = 36
                
                Cells(c.Row - 3, 13).Value = Worksheets("Header").Range("G2:G2").Value '"3 Years"
                Cells(c.Row - 3, 13).Interior.ColorIndex = 36
                Cells(c.Row - 3, 13).Font.Bold = True
                With Cells(c.Row - 3, 13)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
                
                
                'Cells(c.Row - 3, 14).Value = ""
                'Cells(c.Row - 3, 15).Value = ""
                Cells(c.Row - 3, 15).Interior.ColorIndex = 36
                
                Cells(c.Row - 3, 16).Value = Worksheets("Header").Range("H2:H2").Value '"4 Years"
                Cells(c.Row - 3, 16).Interior.ColorIndex = 36
                Cells(c.Row - 3, 16).Font.Bold = True
                With Cells(c.Row - 3, 16)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
                
                
                'Cells(c.Row - 3, 17).Value = ""
                'Cells(c.Row - 3, 18).Value = ""
                Cells(c.Row - 3, 18).Interior.ColorIndex = 36
                
                Cells(c.Row - 3, 19).Value = Worksheets("Header").Range("I2:I2").Value '"5 Years"
                Cells(c.Row - 3, 19).Interior.ColorIndex = 36
                Cells(c.Row - 3, 19).Font.Bold = True
                With Cells(c.Row - 3, 19)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
                
                
                'Cells(c.Row - 3, 20).Value = ""
                'Cells(c.Row - 3, 21).Value = ""
                Cells(c.Row - 3, 21).Interior.ColorIndex = 36
                
                Cells(c.Row - 3, 22).Value = Worksheets("Header").Range("J2:J2").Value '"Post Warranty"
                Cells(c.Row - 3, 22).Interior.ColorIndex = 36
                Cells(c.Row - 3, 22).Font.Bold = True
                With Cells(c.Row - 3, 22)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
                
                
                'Cells(c.Row - 3, 23).Value = ""
                
                Cells(c.Row - 2, 2).Value = Worksheets("Header").Range("A2:A2").Value '"Products Covered"
                Cells(c.Row - 2, 2).Interior.ColorIndex = 36
                Cells(c.Row - 2, 2).Font.Bold = True
                Cells(c.Row - 2, 2).Font.Size = 10
                putBorder Range(Cells(c.Row - 2, 2), Cells(c.Row - 2, 2))
                
                
                'Cells(c.Row - 2, 3).Value = ""
                'Cells(c.Row - 2, 4).Value = ""
                'Cells(c.Row - 2, 5).Value = ""
                'Cells(c.Row - 2, 6).Value = ""
                Cells(c.Row - 2, 7).Value = Worksheets("Header").Range("K2:K2").Value '"Care Pack"
                Cells(c.Row - 2, 7).Interior.ColorIndex = 36
                Cells(c.Row - 2, 7).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 7), Cells(c.Row - 2, 7))
                
                Cells(c.Row - 2, 8).Value = Worksheets("Header").Range("L2:L2").Value '"Price"
                Cells(c.Row - 2, 8).Interior.ColorIndex = 36
                Cells(c.Row - 2, 8).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 8), Cells(c.Row - 2, 8))
                
                'Cells(c.Row - 2, 9).Value = ""
                Cells(c.Row - 2, 10).Value = Worksheets("Header").Range("K2:K2").Value '"Care Pack"
                Cells(c.Row - 2, 10).Interior.ColorIndex = 36
                Cells(c.Row - 2, 10).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 10), Cells(c.Row - 2, 10))
                
                Cells(c.Row - 2, 11).Value = Worksheets("Header").Range("L2:L2").Value '"Price"
                Cells(c.Row - 2, 11).Interior.ColorIndex = 36
                Cells(c.Row - 2, 11).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 11), Cells(c.Row - 2, 11))
                
                'Cells(c.Row - 2, 12).Value = ""
                Cells(c.Row - 2, 13).Value = Worksheets("Header").Range("K2:K2").Value '"Care Pack"
                Cells(c.Row - 2, 13).Interior.ColorIndex = 36
                Cells(c.Row - 2, 13).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 13), Cells(c.Row - 2, 13))
                
                Cells(c.Row - 2, 14).Value = Worksheets("Header").Range("L2:L2").Value '"Price"
                Cells(c.Row - 2, 14).Interior.ColorIndex = 36
                Cells(c.Row - 2, 14).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 14), Cells(c.Row - 2, 14))
                
                'Cells(c.Row - 2, 15).Value = ""
                Cells(c.Row - 2, 16).Value = Worksheets("Header").Range("K2:K2").Value '"Care Pack"
                Cells(c.Row - 2, 16).Interior.ColorIndex = 36
                Cells(c.Row - 2, 16).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 16), Cells(c.Row - 2, 16))
                
                Cells(c.Row - 2, 17).Value = Worksheets("Header").Range("L2:L2").Value '"Price"
                Cells(c.Row - 2, 17).Interior.ColorIndex = 36
                Cells(c.Row - 2, 17).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 17), Cells(c.Row - 2, 17))
                
                'Cells(c.Row - 2, 18).Value = ""
                Cells(c.Row - 2, 19).Value = Worksheets("Header").Range("K2:K2").Value '"Care Pack"
                Cells(c.Row - 2, 19).Interior.ColorIndex = 36
                Cells(c.Row - 2, 19).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 19), Cells(c.Row - 2, 19))
                
                Cells(c.Row - 2, 20).Value = Worksheets("Header").Range("L2:L2").Value '"Price"
                Cells(c.Row - 2, 20).Interior.ColorIndex = 36
                Cells(c.Row - 2, 20).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 20), Cells(c.Row - 2, 20))
                
                'Cells(c.Row - 2, 21).Value = ""
                Cells(c.Row - 2, 22).Value = Worksheets("Header").Range("K2:K2").Value '"Care Pack"
                Cells(c.Row - 2, 22).Interior.ColorIndex = 36
                Cells(c.Row - 2, 22).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 22), Cells(c.Row - 2, 22))
                
                Cells(c.Row - 2, 23).Value = Worksheets("Header").Range("L2:L2").Value '"Price"
                Cells(c.Row - 2, 23).Interior.ColorIndex = 36
                Cells(c.Row - 2, 23).Font.Bold = True
                putBorder Range(Cells(c.Row - 2, 23), Cells(c.Row - 2, 23))
                
                
                'Merge requried cells
                Range(Cells(c.Row - 2, 1), Cells(c.Row - 3, 1)).Merge
                putBorder Range(Cells(c.Row - 2, 1), Cells(c.Row - 3, 1))
                
                Range(Cells(c.Row - 2, 3), Cells(c.Row - 3, 3)).Merge     'Warrnty code
                putBorder Range(Cells(c.Row - 2, 3), Cells(c.Row - 3, 3))
                
                Range(Cells(c.Row - 2, 4), Cells(c.Row - 3, 4)).Merge     'SPL
                putBorder Range(Cells(c.Row - 2, 4), Cells(c.Row - 3, 4))
                
                Range(Cells(c.Row - 2, 5), Cells(c.Row - 3, 5)).Merge     'Service Description
                putBorder Range(Cells(c.Row - 2, 5), Cells(c.Row - 3, 5))
                
                Range(Cells(c.Row - 2, 6), Cells(c.Row - 3, 6)).Merge     'Blank after Service Description
                putBorder Range(Cells(c.Row - 2, 6), Cells(c.Row - 3, 6))
                
                Range(Cells(c.Row - 3, 7), Cells(c.Row - 3, 8)).Merge     '1 Year
                putBorder Range(Cells(c.Row - 3, 7), Cells(c.Row - 3, 8))
                
                Range(Cells(c.Row - 2, 9), Cells(c.Row - 3, 9)).Merge     'Blank after 1 Year
                putBorder Range(Cells(c.Row - 2, 9), Cells(c.Row - 3, 9))
                
                Range(Cells(c.Row - 3, 10), Cells(c.Row - 3, 11)).Merge     '2 Year
                putBorder Range(Cells(c.Row - 3, 10), Cells(c.Row - 3, 11))
                
                Range(Cells(c.Row - 2, 12), Cells(c.Row - 3, 12)).Merge     'Blank after 2 Year
                putBorder Range(Cells(c.Row - 2, 12), Cells(c.Row - 3, 12))
                
                Range(Cells(c.Row - 3, 13), Cells(c.Row - 3, 14)).Merge     '3 Year
                putBorder Range(Cells(c.Row - 3, 13), Cells(c.Row - 3, 14))
                
                Range(Cells(c.Row - 2, 15), Cells(c.Row - 3, 15)).Merge     'Blank after 3 Year
                putBorder Range(Cells(c.Row - 2, 15), Cells(c.Row - 3, 15))
                
                Range(Cells(c.Row - 3, 16), Cells(c.Row - 3, 17)).Merge     '4 Year
                putBorder Range(Cells(c.Row - 3, 16), Cells(c.Row - 3, 17))
                
                Range(Cells(c.Row - 2, 18), Cells(c.Row - 3, 18)).Merge     'Blank after 4 Year
                putBorder Range(Cells(c.Row - 2, 18), Cells(c.Row - 3, 18))
                
                Range(Cells(c.Row - 3, 19), Cells(c.Row - 3, 20)).Merge     '5 Year
                putBorder Range(Cells(c.Row - 3, 19), Cells(c.Row - 3, 20))
                
                Range(Cells(c.Row - 2, 21), Cells(c.Row - 3, 21)).Merge     'Blank after 5 Year
                putBorder Range(Cells(c.Row - 2, 21), Cells(c.Row - 3, 21))

                Range(Cells(c.Row - 3, 22), Cells(c.Row - 3, 23)).Merge     'Post Warrnty
                putBorder Range(Cells(c.Row - 3, 22), Cells(c.Row - 3, 23))
                
             
                Set c = .FindNext(c)
            Loop While Not c Is Nothing
        End If
    End With
    
    'Remove extra fills
    Cells(5, 1).Interior.ColorIndex = xlNone
    Cells(5, 2).Interior.ColorIndex = xlNone
    Cells(5, 3).Interior.ColorIndex = xlNone
    Cells(5, 4).Interior.ColorIndex = xlNone
    Cells(5, 5).Interior.ColorIndex = xlNone



 End Sub
 



Private Sub CreateWaitMessage()

    ActiveWindow.Zoom = 100
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 172#, 172#). _
        Select
    Selection.ShapeRange.ScaleWidth 8.67, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 5.49, msoFalse, msoScaleFromTopLeft
    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 243#, 195.75, _
        249#, 50.25).Select
    Selection.Characters.Text = "Please wait ..."
    With Selection.Characters(Start:=1, Length:=15).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Selection.HorizontalAlignment = xlCenter
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.Font.Bold = True
    'ActiveSheet.Shapes("Rectangle 2").Select
End Sub

Private Sub DeleteWaitMessage()

    'Fix for the excel 2007
    'ActiveSheet.Shapes("Text Box 2").Select
    If Val(Mid(Application.Version, 1, InStr(1, Application.Version, ".") - 1)) > 11 Then
        ActiveSheet.Shapes("TextBox 2").Select
    Else
        ActiveSheet.Shapes("Text Box 2").Select
    End If
    'Fix for the excel 2007 Till here
    
    Selection.Characters.Text = "Please wait ..."
    With Selection.Characters(Start:=1, Length:=15).Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Selection.Delete
    ActiveSheet.Shapes("Rectangle 1").Select
    Selection.Delete
End Sub
Private Sub CheckAnyWorkBookIsOpen()
    If Application.Workbooks.Count > 1 Then
        If MsgBox("All other open Excel workbooks should be closed. Click 'Yes' to save and close all other open workbooks and continue processing. Click 'No' if you want to close all open workbooks manually and then run this process again.", vbYesNo, "CReST PL") = vbYes Then
            For Each oWB In Application.Workbooks
                If oWB.FullName <> ThisWorkbook.FullName Then
                    oWB.Close True
                End If
            Next
        Else
            ThisWorkbook.Close False
        End If
    End If
End Sub
















Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

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