Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 a0ffc52109d2b804…

MALICIOUS

Office (OLE)

6.41 MB Created: 2007-09-06 07:02:44 Authoring application: Microsoft Excel First seen: 2019-05-31
MD5: 2077134ddda264b1ce5d3bf12419539f SHA-1: 2e119296f4ae4ce2fe580bed1037735db4b786d1 SHA-256: a0ffc52109d2b80400d8713f5c8dc8083ef17e324b00e9f225acc158214ca893
348 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1218.005 System Binary Proxy Execution: Mshta

The sample is an Excel file containing a Workbook_Open macro that is heavily obfuscated and uses CreateObject and Shell() calls. Heuristics indicate the use of WScript.Shell and mshta.exe, suggesting an attempt to download and execute a second-stage payload. The obfuscated nature of the macro and the lack of clear indicators for a specific family lead to an unknown family classification.

Heuristics 9

  • VBA macros detected medium 5 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
    Dim objShell As Object                          '//Added by Amar on 08 Feb 2008 for BUG 2728
Set objShell = CreateObject("Wscript.Shell")
 Const btnOK As Integer = 0
  • Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADER
    Auto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.
    Matched line in script
    Dim objShell As Object                          '//Added by Amar on 08 Feb 2008 for BUG 2728
Set objShell = CreateObject("Wscript.Shell")
 Const btnOK As Integer = 0
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
    Dim objShell As Object                          '//Added by Amar on 08 Feb 2008 for BUG 2728
Set objShell = CreateObject("Wscript.Shell")
 Const btnOK As Integer = 0
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Compiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
   Call AddRowInPayable
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • Reference to mshta.exe high SC_STR_MSHTA
    Reference to mshta.exe
  • Suspicious extracted artifact high EXTRACTED_FILE_STATIC_TRIAGE
    One or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 1864072 bytes
SHA-256: 9eac4fd81421b491bd72374fec016658a6f0f962fd136bb50a194bf579cb70cd
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 15 eval/decoder/string-building token(s).
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "Module1"
Public sFlag As String

Sub AddService()

Dim iRows As Integer
'This Macro will Add new Row containing the service List.
If ActiveSheet.Cells(12, 11).Value = 0 Then
    MsgBox "First select Constitution of Assessee."
Exit Sub
End If
' Row selection based on active cell

    Dim X As Long
    Dim iSeIndex As Integer
    Dim iSeNumber As Integer

   'code to find Row Index starts
   ' Dim r As Range
   ' Set r = Cells(18, 4)
    J = 1
    Do While Not UCase(Cells(J, 3)) Like "*998985211*"
    J = J + 1
    Loop
   'code to find Row Index Ends
   'added to activate the Perticular cell Starts
        J = J - 21

    iSeNumber = J + 3
    iSeIndex = J + 21
    range("B20").offset(J, 0).Activate
   'to activate the Perticular cell Ends
   'Code Added to validate that correct Row is Added
    If ActiveCell.Value = 991130171 Then
    If ActiveCell.offset(0, 2).Value = 0 Then
    MsgBox "Please select Taxable Service From the List and then Press Add Button."
    Exit Sub
    End If
   
  
   ActiveCell.EntireRow.Select  'This will select the entire row
   If vRows = 0 Then
   vRows = 1
   If vRows = False Then Exit Sub
   End If

   Dim sht As Worksheet, shts() As String, i As Long
   ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
   Windows(1).SelectedSheets.Count)
   i = 0
   For Each sht In _
   Application.ActiveWorkbook.Windows(1).SelectedSheets
   Sheets(sht.name).Select

    i = i + 1

    shts(i) = sht.name

    X = Sheets(sht.name).UsedRange.Rows.Count 'lastcell fixup

    'Dynamically unprotects the sheet for adding row
    ActiveSheet.Unprotect Password:="extrema"

    Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
     Resize(rowsize:=vRows).Insert Shift:=xlDown

    Selection.AutoFill Selection.Resize( _
     rowsize:=vRows + 1), xlFillDefault

    On Error Resume Next    'to handle no constants in range

    ' to remove the non-formulas

    Selection.offset(1).Resize(vRows).EntireRow. _
     SpecialCells(xlConstants).ClearContents
    
    '''Set the serial number of service
    ActiveSheet.Cells(iSeIndex, 3).Value = iSeNumber
    
    Dim sUnlkSrvcNm As String
    sUnlkSrvcNm = "D" & iSeIndex & ":" & "N" & iSeIndex
    ActiveSheet.range(sUnlkSrvcNm).Locked = False
    'Added by Amardeep on 04September2008 for changing color of new added row to green
    ActiveSheet.range(sUnlkSrvcNm).Interior.ColorIndex = 35
 
  ' Call addNewServiceSheets
   ' Again protects the sheet after adding row
   'Call resetScrollRange
   ActiveSheet.Protect Password:="extrema"
   
   Next sht
   Worksheets(shts).Select

   End If

End Sub

Sub deleteServiceRow_bkp()

'This will ask user before deleting the Row
If MsgBox("Do you want to delete last added service from the list ?" & vbCrLf & "Click on YES will delete the respective Payable Sheet", vbYesNo + vbQuestion) = vbNo _
Then
Exit Sub
End If
'code to find Row Index starts
    Dim TsheetIndex As Integer
    Dim J As Integer
    Dim R As range
    Set R = Cells(18, 3)
    J = 1
    Do While Not UCase(Cells(J, 3)) Like "*998985211*"
    J = J + 1
    Loop

    TsheetIndex = J - 19
      
'code to find Row Index Ends
      
'added to activate the Perticular cell Starts
    J = J - 19
    range("B18").offset(J, 0).Activate
'to activate the Perticular cell Ends
    
'code to prevent user from deleting first Row.
   If ActiveCell.Value <> ActiveCell.offset(-1, 0) Then
   MsgBox "Atleast one service must be present.You can not delete First Row."
   Exit Sub
   Else
   
   If ActiveCell.Value = 991130171 Then
   ActiveSheet.Unprotect Password:="extrema"
  'code to delete last row .
   ActiveCell.Rows.EntireRow.Delete
  'code to delete the related sheets.
   Call deleteWorkSheets(TsheetIndex)
   ActiveSheet.Protect Password:="extrema"
    
    End If
    End If
    
End Sub
'Macro to deleteTaxable service and Respective sheet
'Author : Sarvesh ABrol
'Date   : 09 jul 2010
Sub deleteServiceRow()
'This will ask user before deleting the Row
Dim isNo As Integer
If ActiveCell.offset(0, -1).Value <> "991130171" Then
                MsgBox "Please click on the cell On the Red Cell and then Press Delete button."
                Exit Sub
    Else
    If MsgBox("Do you want to delete last added service from the list ?" & vbCrLf & "Click on YES will      delete the respective Payable Sheet", vbYesNo + vbQuestion) = vbNo _
        Then
    Exit Sub
    End If
    'code to find Row Index starts
        Dim TsheetIndex As Integer
     Dim J As Integer
     Dim R As range
     Set R = Cells(18, 3)
      J = 1
        Do While Not UCase(Cells(J, 3)) Like "*998985211*"
            J = J + 1
     Loop

        TsheetIndex = J - 19
      
'code to find Row Index Ends
      
'added to activate the Perticular cell Starts
   '     J = J - 19
    ' Range("B18").offset(J, 0).Activate
'to activate the Perticular cell Ends
    
'code to prevent user from deleting first Row.
     'If ActiveCell.Value <> ActiveCell.offset(-1, 0) Then
     If TsheetIndex = 1 Then
        MsgBox "Atleast one service must be present.You can not delete First Row."
         Exit Sub
         Else
             If ActiveCell.offset(0, -1).Value = 991130171 Then
        ActiveSheet.Unprotect Password:="extrema"
          'code to delete last row .
        isNo = ActiveCell.Row - 18
           ActiveCell.Rows.EntireRow.Delete
                     'code to delete the related sheets.
           Call deleteWorkSheets(isNo, TsheetIndex)
           ActiveSheet.Protect Password:="extrema"
        End If
        End If
    End If
End Sub


Sub AddNotification()
'This Macro will Add new Row containing the service List.
' Row selection based on active cell

    Dim X As Long
   
    'code to find Row Index starts
    Dim R As range
    Set R = Cells(13, 3)

    J = 1

    Do While Not UCase(Cells(J, 3)) Like "*998985211*"
    J = J + 1
    Loop
    
   'code to find Row Index Ends
   
   'added to activate the Perticular cell Starts
    J = J - 14
    range("C13").offset(J, 0).Activate
        
    'to activate the Perticular cell Ends
      
    'Code Added to validate that correct Row is Added
     If ActiveCell.Value = 991130171 Then
   If ActiveCell.Next.Value = 0 Then
   MsgBox "Please select notification and then Press Add Button."
   Exit Sub
   End If
   
   'addded on 11 Sept for Allowing Add only at Last
   
   If ActiveCell.offset(1, 0).Value <> 998985211 Then
   MsgBox "You can not Add Row here."
   Exit Sub
   End If
    
    ActiveCell.EntireRow.Select  'This will select the entire row
    If vRows = 0 Then

    'vRows = Application.InputBox(prompt:= _
    ' "How many rows do you want to add?", Title:="Add Rows", _
    ' Default:=1, Type:=1) 'Default for 1 row, type 1 is number

     vRows = 1
    If vRows = False Then Exit Sub

   End If

   Dim sht As Worksheet, shts() As String, i As Long
   ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
   Windows(1).SelectedSheets.Count)
   i = 0
   For Each sht In _
   Application.ActiveWorkbook.Windows(1).SelectedSheets
   Sheets(sht.name).Select

    i = i + 1

    shts(i) = sht.name

    X = Sheets(sht.name).UsedRange.Rows.Count 'lastcell fixup

   'Dynamically unprotects the sheet for adding row
    ActiveSheet.Unprotect Password:="extrema"

    Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
     Resize(rowsize:=vRows).Insert Shift:=xlDown

 
    Selection.AutoFill Selection.Resize( _
     rowsize:=vRows + 1), xlFillDefault

    On Error Resume Next    'to handle no constants in range

    ' to remove the non-formulas

    Selection.offset(1).Resize(vRows).EntireRow. _
     SpecialCells(xlConstants).ClearContents
   
   'Dynamically Protects the sheet After adding row
    ActiveSheet.Protect Password:="extrema"

   Next sht

   Worksheets(shts).Select

   End If

End Sub
Sub deleteNotificationRow()

    If ActiveCell.Value <> ActiveCell.offset(-1, 0) Then
    MsgBox "Please click on the cell in Red colour to select the Notification and then Press Delete Button.(You can not delete the first row.)"
    Else
    If ActiveCell.Value = 991130171 Then
    
    ActiveSheet.Unprotect Password:="extrema"
    
    ActiveCell.Rows.EntireRow.Delete
    
    ActiveSheet.Protect Password:="extrema"
    
    Else
    MsgBox "Please click on the cell in Red colour and then Press Delete Button."
    End If
    End If

End Sub

Sub AddDocument()
'This Macro will Add new Row containing the service List.
' Row selection based on active cell

    Dim X As Long
   
    'code to find Row Index starts
    Dim R As range
    Set R = Cells(15, 3)

    J = 1

    Do While Not UCase(Cells(J, 3)) Like "*998985211*"
    J = J + 1
    Loop
   'code to find Row Index Ends
   
   'added to activate the Perticular cell Starts
    J = J - 16
    range("C15").offset(J, 0).Activate
        
    'to activate the Perticular cell Ends
        
    'Code Added to validate that correct Row is Added
    
   If ActiveCell.Value = 991130171 Then
   If ActiveCell.Next.Value = 0 Then
   MsgBox "Please select payment type and then Press Add Button."
   Exit Sub
   End If
   
         If ActiveCell.Value = 991130171 Then
   If ActiveCell.offset(0, 8).Value = 0 Then
   MsgBox "Please enter Month/Quarter for souce document number and then Press Add Button."
   Exit Sub
   End If
   End If
   
   
      If ActiveCell.Value = 991130171 Then
   If ActiveCell.offset(0, 9).Value = 0 Then
   MsgBox "Please enter souce document number and then Press Add Button."
   Exit Sub
   End If
   End If
   
               If ActiveCell.Value = 991130171 Then
   If ActiveCell.offset(0, 11).Value = 0 Then
   MsgBox "Please enter Date for souce document number and then Press Add Button."
   Exit Sub
   End If
   End If
   'addded on 11 Sept for Allowing Add only at Last
   
   If ActiveCell.offset(1, 0).Value <> 998985211 Then
   MsgBox "You can not Add Row here."
   Exit Sub
   End If
    
    ActiveCell.EntireRow.Select  'This will select the entire row
    If vRows = 0 Then

    'vRows = Application.InputBox(prompt:= _
    ' "How many rows do you want to add?", Title:="Add Rows", _
    ' Default:=1, Type:=1) 'Default for 1 row, type 1 is number

     vRows = 1
    If vRows = False Then Exit Sub

   End If

   Dim sht As Worksheet, shts() As String, i As Long
   ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
   Windows(1).SelectedSheets.Count)
   i = 0
   For Each sht In _
   Application.ActiveWorkbook.Windows(1).SelectedSheets
   Sheets(sht.name).Select

    i = i + 1

    shts(i) = sht.name

    X = Sheets(sht.name).UsedRange.Rows.Count 'lastcell fixup
    
    'Dynamically unprotects the sheet for adding row
    ActiveSheet.Unprotect Password:="extrema"

    Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
     Resize(rowsize:=vRows).Insert Shift:=xlDown
 
    Selection.AutoFill Selection.Resize( _
     rowsize:=vRows + 1), xlFillDefault

    On Error Resume Next    'to handle no constants in range -- John McKee 2000/02/01

    ' to remove the non-formulas -- 1998/03/11 Bill Manville

    Selection.offset(1).Resize(vRows).EntireRow. _
     SpecialCells(xlConstants).ClearContents

   'Dynamically Protects the sheet after adding row
    ActiveSheet.Protect Password:="extrema"

   Next sht

   Worksheets(shts).Select

  Else

 MsgBox "Error Please contact Administrator."
 End If

End Sub
Sub deleteDocumentRow()

    If ActiveCell.Value <> ActiveCell.offset(-1, 0) Then
    MsgBox "Please click on the cell in Red colour and then Press Delete Button.(You can not delete the first row.)"
    Else
    If ActiveCell.Value = 991130171 Then
    ActiveSheet.Unprotect Password:="extrema"
    ActiveCell.Rows.EntireRow.Delete
    ActiveSheet.Protect Password:="extrema"
    
    Else
    MsgBox "Please click on the cell in Red colour and then Press Delete Button."
    End If
    End If

End Sub
Function validateFinancialYear(FinYear As String) As Boolean

    Dim iChIndex As Integer
    Dim sChValueOne As Integer
    Dim sChValueTwo As Integer
    
    sChValueOne = Mid(FinYear, 1, 4)
    sChValueTwo = Mid(FinYear, 6, 4)
    If Not (sChValueTwo = sChValueOne + 1) Then
    validateFinancialYear = True: Exit Function
    End If
    
    For iChIndex = 1 To 4
    sChValue = Mid(FinYear, iChIndex, 1)
    If sChValue >= 0 And sChValue <= 9 Then
    Else
    validateFinancialYear = True: Exit Function
    End If
    Next iChIndex

    If iChIndex = 5 Then
    sChValue = Mid(FinYear, 5, 1)
    If sChValue = "-" Then
    Else
    validateFinancialYear = True: Exit Function
    End If
    End If
    
    For iChIndex = 6 To 9
    sChValue = Mid(FinYear, iChIndex, 1)
    If sChValue >= 0 And sChValue <= 9 Then
    Else
    validateFinancialYear = True: Exit Function
    End If
    Next iChIndex

End Function

Sub validateScreenOne()

Dim wsScreenOne As Worksheet
Dim RegNum As String
Dim FinYear As String
Dim SingRet As String
Dim PremiseCode As String
Set wsScreenOne = Worksheets("Return")

RegNum = wsScreenOne.Cells(6, 6).Value
AseName = wsScreenOne.Cells(6, 12).Value
FinYear = wsScreenOne.Cells(7, 6).Value
RetPeriod = wsScreenOne.Cells(7, 12).Value
SingRet = wsScreenOne.Cells(8, 6).Value
LtuFlag = wsScreenOne.Cells(9, 11).Value
LtuCity = wsScreenOne.Cells(10, 11).Value
PremiseCode = wsScreenOne.Cells(11, 11).Value
ConstAse = wsScreenOne.Cells(12, 11).Value

Dim sErrorMsg As String

If Len(RegNum) = 0 Then
sErrorMsg = "STC Number is required."
End If

If Len(AseName) = 0 Then
sErrorMsg = sErrorMsg & vbCrLf & "Assessee Name is required."
End If

If Len(FinYear) = 0 Then
sErrorMsg = sErrorMsg & vbCrLf & "Financial Year is required.(e.g. 2006-2007)"
End If

If Len(RetPeriod) = 0 Then
sErrorMsg = sErrorMsg & vbCrLf & "Return Period is required."
End If

If Len(SingRet) = 0 Then
sErrorMsg = sErrorMsg & vbCrLf & "Please select option of Single Return."
End If

If Len(LtuFlag) = 0 Then
sErrorMsg = sErrorMsg & vbCrLf & "Please select option of LTU(1A)"
End If

If (LtuFlag = "Yes") And (Len(LtuCity) = 0) Then
sErrorMsg = sErrorMsg & vbCrLf & "Please enter the Name of City for LTU(1B)."
End If

If Len(PremiseCode) = 0 Then
sErrorMsg = sErrorMsg & vbCrLf & "Premise Code is required."
Else
    If ValidatePremisesCode(PremiseCode) = False Then
     sErrorMsg = sErrorMsg & vbCrLf & "Please enter Premises code in correct format.It will accept 10 digit alphanumeric characters only."
    End If
End If

'If (Len(PremiseCode) > 6) Or (Len(PremiseCode) > 0 And Len(PremiseCode) < 6) Then
'sErrorMsg = sErrorMsg & vbCrLf & "Premise Code accepts 6 digits only."
'End If

If Len(ConstAse) = 0 Then
sErrorMsg = sErrorMsg & vbCrLf & "Constitution of Assessee is required."
End If


If Len(RegNum) > 0 Then
If ValidateRegistrationNumber(RegNum) = True Then
sErrorMsg = sErrorMsg & vbCrLf & "Please enter STC Number in correct format : XXXXXnnnnXSTnnn (Example TEMPA0098XST001)"
End If
End If


If Len(FinYear) > 0 Then
If validateFinancialYear(FinYear) = True Then
sErrorMsg = sErrorMsg & vbCrLf & "Please enter Financial Year in correct format. e.g. 2006-2007 "
End If
End If

'ValidateMonthYear

If Len(FinYear) > 0 And Len(RetPeriod) > 0 Then
If ValidateMonthYear = True Then
sErrorMsg = sErrorMsg & vbCrLf & "You can not file return for the current or future period."
End If
End If

If ValidateDplctSrvcs = True Then
sErrorMsg = sErrorMsg & vbCrLf & "Duplicate Taxable Services are not allowed, Please select unique service from the List."
End If

'lalita
If ValidateBlankSrvcs_check = False Then
sErrorMsg = sErrorMsg & vbCrLf & "Please Select Taxable Service from the List."
'sErrorMsg = sErrorMsg & vbCrLf & "Please Fill all the values in Taxable Service section."
End If
'end

If Len(sErrorMsg) > 0 Then
MsgBox "" & sErrorMsg, vbCritical, "Errors on Return Sheet"

End If

If Len(sErrorMsg) = 0 Then
MsgBox "The sheet is validated."
End If

End Sub

''method :updateSubClause
''Author : Amardeep
''date :05 april 2012
'Purpose : update the subclause automatically
Sub updateSubClause(iSheetIndex As Integer)

Dim wsReturn As Worksheet
Dim wsMaster As Worksheet
Dim RowNumber As Integer
''Dim sServiceVal As String


Set wsReturn = Worksheets("Return")
Set wsMaster = Worksheets("Master")

RowNumber = iSheetIndex + 18
sServiceVal = wsReturn.Cells(RowNumber, 4)

            iCountTwo = 1
            Do While Not UCase(wsMaster.Cells(iCountTwo, 23)) = UCase(sServiceVal)
            iCountTwo = iCountTwo + 1
            Loop
            subclauseCode = wsMaster.Cells(iCountTwo, 24)
Sheets("Return").Unprotect Password:="extrema"
wsReturn.Cells(RowNumber, 14).Value = subclauseCode
Sheets("Return").Protect Password:="extrema"

End Sub


Sub addNewServiceSheets(iSheetId As Integer)

Dim wsReturn As Worksheet
Set wsReturn = Worksheets("Return")
Dim sContutnFlag As String
sContutnFlag = wsReturn.Cells(12, 19).Value
'''To add the sheets of monthly return
If (sContutnFlag = "M") Then

Dim wsPayableService As Worksheet
Dim wsPaidService As Worksheet
Dim wsChallanService As Worksheet

'The workbook is unprotected here
ActiveWorkbook.Unprotect Password:="extrema"
Application.ScreenUpdating = False
'The Master worksheets are make visible here
Worksheets("Payable-Service").Visible = True

If iSheetId = 1 Then
Worksheets("Paid-Service").Visible = True
Worksheets("Challan-Service").Visible = True
Worksheets("Advance-Payment").Visible = True
End If

Set wsPayableService = Worksheets("Payable-Service")
Set wsPaidService = Worksheets("Paid-Service")
Set wsChallanService = Worksheets("Challan-Service")
oldSheet$ = ActiveSheet.name

wsPayableService.Copy Before:=Sheets("Advance-Payment")

If iSheetId = 1 Then
Worksheets("Payable-Service (2)").name = "Payable-Service (1)"
End If

Worksheets(oldSheet$).Activate

'The Master worksheets are make hidden here again
Worksheets("Payable-Service").Visible = False
'The workbook is Protected here again
ActiveWorkbook.Protect Password:="extrema"
'Application.ScreenUpdating = True
End If

'''To add the sheets of Quarterly return
If (sContutnFlag = "Q") Then

Dim wsPayableQuarter As Worksheet
Dim wsPaidQuarter As Worksheet
Dim wsChallanQuarter As Worksheet

'The workbook is unprotected here
ActiveWorkbook.Unprotect Password:="extrema"
Application.ScreenUpdating = False
'The Master worksheets are make visible here

Worksheets("Payable-Quart-Service").Visible = True

If iSheetId = 1 Then
Worksheets("Paid-Quarterly-Service").Visible = True
Worksheets("Challan-Service").Visible = True
Worksheets("Advance-Payment-Quarterly").Visible = True
End If

Set wsPayableQuarter = Worksheets("Payable-Quart-Service")
Set wsPaidQuarter = Worksheets("Paid-Quarterly-Service")
Set wsChallanQuarter = Worksheets("Challan-Service")
oldSheet$ = ActiveSheet.name

wsPayableQuarter.Copy Before:=Sheets("Advance-Payment-Quarterly")

If iSheetId = 1 Then
Worksheets("Payable-Quart-Service (2)").name = "Payable-Quart-Service (1)"
End If

Worksheets(oldSheet$).Activate

'The Master worksheets are make hidden here again
Worksheets("Payable-Quart-Service").Visible = False

'The workbook is Protected here again
ActiveWorkbook.Protect Password:="extrema"

'Application.ScreenUpdating = True
End If

End Sub

Sub deleteWorkSheets_bkp(TsheetIndex As Integer)

Dim wsReturn As Worksheet
Set wsReturn = Worksheets("Return")
Dim sContutnFlag As String
sContutnFlag = wsReturn.Cells(12, 19).Value

Dim i As Integer
Dim sht As Object

        If (sContutnFlag = "M") Then
            i = TsheetIndex
            
            Application.DisplayAlerts = False
            ActiveWorkbook.Unprotect Password:="extrema"
            If WorksheetExists("Payable-Service (" & i & ")") = True Then
            Worksheets("Payable-Service (" & i & ")").Delete
            End If
           If WorksheetExists("Paid-Service (" & i & ")") = True Then
             
            Worksheets("Paid-Service (" & i & ")").Delete
             End If
             If WorksheetExists("Challan-Service (" & i & ")") = True Then
            Worksheets("Challan-Service (" & i & ")").Delete
             End If
            Application.DisplayAlerts = True
            ActiveWorkbook.Protect Password:="extrema"
        
        End If
        
        If (sContutnFlag = "Q") Then
            i = TsheetIndex
            
            Application.DisplayAlerts = False
            ActiveWorkbook.Unprotect Password:="extrema"
            
          If WorksheetExists("Payable-Quart-Service (" & i & ")") = True Then
              Worksheets("Payable-Quart-Service (" & i & ")").Delete
               End If
           If WorksheetExists("Paid-Quarterly-Service (" & i & ")") = True Then
             Worksheets("Paid-Quarterly-Service (" & i & ")").Delete
              End If
           If WorksheetExists("Challan-Service (" & i & ")") = True Then
             Worksheets("Challan-Service (" & i & ")").Delete
              End If
            
            Application.DisplayAlerts = True
            ActiveWorkbook.Protect Password:="extrema"
        
        End If


End Sub
Sub deleteWorkSheets(isNo As Integer, TsheetIndex As Integer)

Dim wsReturn As Worksheet
Set wsReturn = Worksheets("Return")
Dim ws As String
Dim sContutnFlag As String
sContutnFlag = wsReturn.Cells(12, 19).Value

Dim i As Integer
Dim sht As Object

        If (sContutnFlag = "M") Then
            i = isNo
             Application.DisplayAlerts = False
            ActiveWorkbook.Unprotect Password:="extrema"
            If WorksheetExists("Payable-Service (" & i & ")") = True Then
                    Worksheets("Payable-Service (" & i & ")").Delete
            End If
            'Set ws = Worksheets("Payable-Service")
            ws = "Payable-Service"
                    Call SerialSheet(isNo, TsheetIndex, ws)

           If WorksheetExists("Paid-Service (" & i & ")") = True Then
                         Worksheets("Paid-Service (" & i & ")").Delete
             End If
             'Set ws = Worksheets("Paid-Service")
             ws = "Paid-Service"
                    Call SerialSheet(isNo, TsheetIndex, ws)

             If WorksheetExists("Challan-Service (" & i & ")") = True Then
                Worksheets("Challan-Service (" & i & ")").Delete
             End If
                ws = "Challan-Service"
                    Call SerialSheet(isNo, TsheetIndex, ws)

            Application.DisplayAlerts = True
            ActiveWorkbook.Protect Password:="extrema"
        
        End If
        
        If (sContutnFlag = "Q") Then
            i = isNo
            
            Application.DisplayAlerts = False
            ActiveWorkbook.Unprotect Password:="extrema"
            
             If WorksheetExists("Payable-Quart-Service (" & i & ")") = True Then
                    Worksheets("Payable-Quart-Service (" & i & ")").Delete
               End If
                   ws = "Payable-Quart-Service"
                     Call SerialSheet(isNo, TsheetIndex, ws)
    
    If WorksheetExists("Paid-Quarterly-Service (" & i & ")") = True Then
                    Worksheets("Paid-Quarterly-Service (" & i & ")").Delete
              End If
                 ws = "Paid-Quarterly-Service"
                      Call SerialSheet(isNo, TsheetIndex, ws)


            If WorksheetExists("Challan-Service (" & i & ")") = True Then
                 Worksheets("Challan-Service (" & i & ")").Delete
              End If
                  ws = "Challan-Service"
                    Call SerialSheet(isNo, TsheetIndex, ws)
                ' For iCount = isNo To TsheetIndex
                    '  iOnelessCount = iCount - 1
                '    If WorksheetExists("Challan-Service (" iCount & ")") = True Then
                    'Worksheets("Challan-Service (" & iCount & ")").name ="Challan-Service ("  & iOnelessCount & ")"
               ' End If
' Next

            
            Application.DisplayAlerts = True
            ActiveWorkbook.Protect Password:="extrema"
        
        End If


End Sub
Sub SerialSheet(isNo As Integer, TsheetIndex As Integer, wk As String)
Dim iCount As Integer
Dim iOnelessCount As Integer
                      
For iCount = isNo To TsheetIndex
     iOnelessCount = iCount - 1
     If WorksheetExists(wk & " (" & iCount & ")") = True Then
        Worksheets(wk & " (" & iCount & ")").name = wk & " (" & iOnelessCount & ")"
     End If
 Next

End Sub



Function WorksheetExists(WorksheetName As String) As Boolean

Dim sht As Object
For Each sht In ActiveWorkbook.Sheets
If sht.name = WorksheetName Then WorksheetExists = True: Exit For
Next sht
End Function

Function ValidateRegistrationNumber(RegNum As String) As Boolean

If Len(RegNum) = 0 Then
ValidateRegistrationNumber = True: Exit Function
End If

For i = 1 To 5
Ch = Mid(RegNum, i, 1)
If Ch >= "A" And Ch <= "Z" Then

Else
ValidateRegistrationNumber = True: Exit Function
End If
Next i

For i = 6 To 9
Ch = Mid(RegNum, i, 1)
If Ch >= 0 And Ch <= 9 Then
Else
ValidateRegistrationNumber = True: Exit Function
End If
Next i

For i = 10 To 12

If i = 10 Then
ch10 = Mid(RegNum, 10, 1)
If ch10 >= "A" And ch10 <= "Z" Then
Else
ValidateRegistrationNumber = True: Exit Function
End If
End If

If i = 11 Then
ch11 = Mid(RegNum, 11, 1)
If ch11 = "S" Then
Else
ValidateRegistrationNumber = True: Exit Function
End If
End If


If i = 12 Then
ch12 = Mid(RegNum, 12, 1)
If ch12 = "T" Or ch12 = "D" Then
Else
ValidateRegistrationNumber = True: Exit Function
End If
End If
Next i

For i = 13 To 15
Ch = Mid(RegNum, i, 1)
If Ch >= 0 And Ch <= 9 Or Ch >= "A" And Ch <= "Z" Then
Else
ValidateRegistrationNumber = True: Exit Function
End If
Next i

End Function
'For validating PRA
Function ValidatePRAFunction(sPRAvalue As String)
Dim praExpression As New RegExp
 Dim sPRAPattern As String
    sPRAPattern = "^[A-Z][A-Z][A-Z][A-Z][A-Z][0-9][0-9][0-9][0-9][A-Z](ST|SD|SE)[0-9][0-9][0-9]_(ST3A)_(0[1-9]|1[012])((19|20)\d\d)$"
    praExpression.Pattern = sPRAPattern
 If praExpression.Test(sPRAvalue) = True Then
ValidatePRAFunction = True: Exit Function
End If
End Function
'Sarvesh Abrol
'Validate function for payable sheet
Sub validatePayable()

Dim iRowCount As Integer
Dim iNtfShift As Integer
Dim sErrorMesg As String
Dim sPRAPattern As String
Dim SproviderFlag As String
Dim SrecieverFlag As String
Dim subClause As String
Dim notificationFlag As String
Dim sPRAFlag As String
Dim iRowsPresent As Integer
Dim iTariffRows As Integer
Dim iTariffRows1 As Integer
 Dim iAdditionalValue As Long
Dim iRcntr As Integer
Dim blFlagNegt As Boolean
Dim sPablshtName As String
Dim wsPblSheet As Worksheet

Dim wsReturn As Worksheet
Set wsReturn = Worksheets("Return")
Dim wsHelp As Worksheet
Set wsHelp = Worksheets("Help")
'sPablshtName
Dim iNotificationRows As Integer
        sPablshtName = ActiveSheet.name
        iRcntr = 1
        Do While Not UCase(ActiveSheet.Cells(iRcntr, 3)) Like "*998985211*"
        iRcntr = iRcntr + 1
        Loop
        iNotificationRows = iRcntr - 15
iRowCount = 1
    Do While Not UCase(ActiveSheet.Cells(iRowCount, 3)) Like "*998985211*"
    iRowCount = iRowCount + 1
    Loop
    iNtfShift = iRowCount + 5
    iNtfAnswerShft = iRowCount + 4

SproviderFlag = ActiveSheet.Cells(7, 13).Value
SrecieverFlag = ActiveSheet.Cells(8, 13).Value
subClause = ActiveSheet.Cells(9, 13).Value
sPRAAnswer = ActiveSheet.Cells(iNtfAnswerShft, 11).Value
sPRAFlag = ActiveSheet.Cells(iNtfShift, 11).Value
notificationFlag = ActiveSheet.Cells(11, 13).Value
notifiNumber = ActiveSheet.Cells(14, 4).Value
'Validate provider or recipient
If Len(SproviderFlag) = 0 Then
sErrorMesg = sErrorMesg & vbCrLf & "Please select option from the Serial No. A2 (i)"
End If

If Len(SrecieverFlag) = 0 Then
sErrorMesg = sErrorMesg & vbCrLf & "Please select option from the Serial No. (ii)"
End If

If (SproviderFlag = "No") And (SrecieverFlag = "No") Then
sErrorMesg = sErrorMesg & vbCrLf & "Serial No. A2 (i) and (ii) both can not be NO."
End If
'Validating Subclause
'If Len(subClause) = 0 Then
'sErrorMesg = sErrorMesg & vbCrLf & "Please enter value for the Sub clause number i.e. Section B"
'End If

'Validating PRA
If (sPRAAnswer = "Yes") And (sPRAFlag = "") Then
sErrorMesg = sErrorMesg & vbCrLf & "As You have selected Yes to the Serial number E1., Provisional Assessment Order Number is mandatory in the selected condition."
ElseIf sPRAAnswer = "Yes" Then
'If ValidatePRAFunction(ActiveSheet.Cells(iNtfShift, 11).Value) = "False" Then
If ValidatePRAFunction(ActiveSheet.Cells(iNtfShift, 11).Value) = "True" Then    'by Lalita for PRA
    'MsgBox "Correct PRA format"
    Else
    sErrorMesg = sErrorMesg & vbCrLf & "PRA number entered is not in correct format as: XXXXXnnnnXSTnnn_ST3A_MMYYYY or XXXXXnnnnXSDnnn_ST3A_MMYYYY"
…

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