Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 fa602f1b5b87b24e…

MALICIOUS

Office (OOXML)

1.74 MB Created: 2006-09-16 00:00:00 UTC Authoring application: Microsoft Excel 14.0300 First seen: 2021-09-27
MD5: 23ae0546ab790b35b925ab80b017c7df SHA-1: b0aa3eea4012b7a2e3021b9a7de5f44f28b59634 SHA-256: fa602f1b5b87b24ea1affecd9c8a882073ecd9fdc4120ffbf52a488e2a85879f
494 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1071.001 Web Protocols

The sample is an Excel document containing malicious VBA macros. The macros utilize WScript.Shell and URLDownloadToFile to download and execute a second-stage payload from URLs such as http://bdshenji.com/wpsvba.exe. The presence of a Workbook_Open macro and CreateObject calls further indicates malicious intent, likely to establish persistence or download further malware. The document body contains what appears to be accounting or financial data, suggesting a lure for financial-themed phishing or scams.

Heuristics 14

  • VBA project inside OOXML medium 10 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
                            Shell "explorer " & mypath, vbNormalFocus
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        Set WshShell = CreateObject("WScript.Shell")
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
                        Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
  • LOLBin reference in VBA critical OLE_VBA_LOLBIN
    LOLBin reference in VBA
    Matched line in script
                        Shell "rundll32.exe C:\WINDOWS\system32\shimgvw.dll,ImageView_Fullscreen " & mypath & File.Name, vbNormalFocus
  • VBA downloads and writes a file to disk critical OLE_VBA_HTTP_DROP_EXEC
    VBA reads an HTTP response body and writes it to disk (ADODB.Stream SaveToFile). Combined with the auto-exec/Shell paths this is a download-drop dropper even when the COM ProgIDs are built dynamically to evade keyword scanning.
    Matched line in script
                            s.write h.Responsebody
  • 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, ILine
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set Fso = CreateObject("Scripting.FileSystemObject")
  • 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()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        MsgBox " 当前计算机名  " & VBA.Environ("computername")
  • External hyperlinks (3) low OOXML_EXTERNAL_HYPERLINKS
    Document contains 3 external hyperlinks — clickable URLs are stored as external relationships. First target: https://jingyan.baidu.com/article/154b463113fbf228ca8f41ba.html
  • Hidden worksheet (hidden) low OOXML_HIDDEN_SHEET
    Excel workbook contains 52 hidden sheet(s) — hidden sheets are commonly used to conceal macro code, staging data, or intermediate payload construction
  • 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.soft2016.com/Rec0017.mp4 Referenced by macro
    • http://www.soft2016.com/erweimashipin/Rec0002.mp4Referenced by macro
    • http://www.soft2016.com/erweimashipin/Rec0001.mp4Referenced by macro
    • http://bdshenji.com/wpsvba.exeReferenced by macro
    • http://bdshenji.com/9000052.aspReferenced by macro
    • http://bdshenji.com/������������������excel���.exeReferenced by macro
    • http://www.soft2016.com/������������������excel���.exeReferenced by macro
    • http://www.soft2016.com/share.htmlReferenced by macro
    • http://bdshenji.com/������������excel��.exeReferenced by macro
    • http://www.soft2016.com/������������excel��.exeReferenced by macro
    • https://wenku.baidu.com/view/b5f99978a26925c52cc5bf49.htmlReferenced by macro
    • https://jingyan.baidu.com/article/154b463113fbf228ca8f41ba.htmlReferenced by macro
    • https://baike.baidu.com/item/财务指标分析/6117792?fr=aladdinReferenced by macro
    • http://www.le.com/ptv/vplay/27439602.htmlReferenced by macro
    • http://www.le.com/ptv/vplay/27439156.htmlReferenced by macro
    • http://www.le.com/ptv/vplay/27622959.htmlReferenced by macro
    • https://item.taobao.com/item.htm?id=588961362750Referenced by macro
    • http://www.iec.chReferenced by macro

Extracted artifacts 5

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 686175 bytes
SHA-256: 309a3c7a7d58e18ec71c78cb35b566a861a4b6cbb977e4c3c6e6efd197769b6d
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_Activate()

    On Error Resume Next
     With Sheets("账套基础信息表")
        If .Cells(100, 3).Value = 1 Then
                Exit Sub
            Else
                .Cells(100, 3).Value = 1
        End If
    End With
    
   
    Call youjiancaidan01
    

    With Sheets("账套基础信息表")
        .Cells(100, 3).Value = ""
    End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    On Error Resume Next
    
    With Sheets("凭证表")
        .TextBox1.Visible = False
        .ListBox1.Visible = False
        .ListBox1.Width = 2
        .ListBox1.Height = 2
    End With
    
    With Sheets("账套基础信息表")
        If .Cells(100, 3).Value = "" Then
        
            
            
            Call chongzhi
        End If
    End With
    
    
    
    
    
    Application.MoveAfterReturnDirection = xlDown
    
    With Sheets("首页")
        .Visible = True
        .Activate
        .Cells(1, 1).Select
        .Move before:=Sheets("凭证表")
    End With
    
    Application.OnTime thetime, "Backup", , False
    
End Sub

Private Sub Workbook_Deactivate()
    On Error Resume Next
    
    
    With Sheets("账套基础信息表")
        If .Cells(100, 3).Value = "" Then
            
            
            Call chongzhi
        End If
    End With
    
    Application.Calculation = xlAutomatic

End Sub

Private Sub Workbook_Open()
    
    Application.ScreenUpdating = False
    
    With Sheets("首页")
        .Visible = False
    End With
    
    
    
    
    

    On Error Resume Next
    
    With Application.ActiveProtectedViewWindow
        .Edit
    End With
    On Error GoTo 0
 
 
    
    With Sheets("账套基础信息表")
        If .Cells(24, 3).Value = 1 Then
                bh = 1
            Else
                bh = 0
        End If
        If .Cells(25, 3).Value = "" Then
                ps = ""
            Else
                ps = (Sheets("账套基础信息表").Cells(25, 3).Value - 776) / 3
        End If
        If .Cells(18, 3).Value = 1 Then
                p5 = 1
            Else
                p5 = 0
        End If
        If .Cells(21, 3).Value = 1 Then
                p7 = 1
            Else
                p7 = 0
        End If
        
        If .Cells(30, 3).Value = 1 Then
                p9 = 1
            Else
                p9 = 0
        End If
        
        
        If .Cells(19, 3).Value = 1 Then
                xj02 = 1
            Else
                xj02 = 0
        End If
        If .Cells(27, 3).Value = "" Then
                yuetishi = True
            Else
                yuetishi = False
        End If
        If .Cells(28, 3).Value = 1 Then
                zhineng15 = 1
            Else
                zhineng15 = 0
        End If
        If .Cells(95, 3).Value <> 1 Then
                Flag = True
            Else
                Flag = False
        End If
        
        If .Cells(29, 3).Value = "" Then
                xsd = 30
            Else
                xsd = .Cells(29, 3).Value
        End If
        
    End With
    
    
    
    fz = 0
    If Flag = True Then Call Backup

    
    Call wps01
    If wpshuanjing = True Then
        With Sheets("凭证表")
            If .Columns("v:v").ColumnWidth <> 2.88 Then .Columns("v:v").ColumnWidth = 2.88
        End With
    
    End If
    
    Application.ScreenUpdating = False
    
    
    
    
    
    
    On Error Resume Next
    
 
    
    If Sheets("视频教程").Visible = True Then Sheets("视频教程").Move after:=Sheets("凭证表")
    If Sheets("备忘录").Visible = True Then Sheets("备忘录").Move after:=Sheets("凭证表")
    If Sheets("费用分摊表").Visible = True Then Sheets("费用分摊表").Move after:=Sheets("凭证表")
    If Sheets("现金流量表").Visible = True Then Sheets("现金流量表").Move after:=Sheets("凭证表")
    If Sheets("利润表").Visible = True Then Sheets("利润表").Move after:=Sheets("凭证表")
    If Sheets("资产负债表").Visible = True Then Sheets("资产负债表").Move after:=Sheets("凭证表")
    If Sheets("科目余额表02").Visible = True Then Sheets("科目余额表02").Move after:=Sheets("凭证表")
    If Sheets("科目余额表").Visible = True Then Sheets("科目余额表").Move after:=Sheets("凭证表")
    If Sheets("科目汇总表").Visible = True Then Sheets("科目汇总表").Move after:=Sheets("凭证表")
    If Sheets("数量金额明细账").Visible = True Then Sheets("数量金额明细账").Move after:=Sheets("凭证表")
    If Sheets("明细账").Visible = True Then Sheets("明细账").Move after:=Sheets("凭证表")
    If Sheets("项目核算科目期初余额表").Visible = True Then Sheets("项目核算科目期初余额表").Move after:=Sheets("凭证表")
    If Sheets("项目核算表").Visible = True Then Sheets("项目核算表").Move after:=Sheets("凭证表")
    If Sheets("固定资产表").Visible = True Then Sheets("固定资产表").Move after:=Sheets("凭证表")
    If Sheets("科目设置表").Visible = True Then Sheets("科目设置表").Move after:=Sheets("凭证表")
    
    Sheets("凭证表").Activate
    
    Application.ScreenUpdating = True
    
    
    
    
    
    
    
    
    
    
    If InStrRev(Application.Caption, "Microsoft") <> 0 Then
        
        If Val(Application.Version) < 14 Then
        
            MsgBox "当前财务系统运行环境提示：" & vbCrLf & "" & vbCrLf & "   检测到当前office版本为2010以下版本，本财务系统正常运行已不再支持2010以下excel版本，需要安装2010以上版本office或wps2019以上版本。" & vbCrLf & "请尽快卸载当前版本office并安装2010或以上版本office或wps2019以上版本，以便能正常运行本财务系统的最新功能。避免出现运行错误。" & vbCrLf & "如需office2010完整版安装程序，也可以联系客服免费领取。" & vbCrLf & "" & vbCrLf & ""
            
            
        
        End If
    End If

    
    
End Sub
 

Attribute VB_Name = "UserForm7"
Attribute VB_Base = "0{0BDDA363-1914-4614-BAFF-4D23C18F557E}{941A76D3-71FC-421B-AB62-5818E3659002}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub CommandButton1_Click()
         
    Application.EnableEvents = False
    
    
    
    If Cells(3, 2).Value = "" Or Cells(3, 2).Value = 1 Then
        Cells(3, 2).Value = TextBox1.Text & "1"
    End If
    
    If Cells(3, 2).Value = "记-11" Then Cells(3, 2).Value = "记-1"
    
    Unload Me
    
    
End Sub
 

Private Sub TextBox1_Change()
      If VBA.IsNumeric(VBA.Right(TextBox1.Text, 1)) = True Then
            MsgBox "错误提示： 自动添加的凭证字，最后不能数字结尾。（设置自动添加凭证字后，在录入凭证号时只需要录入后面数字部分，前面的部分会自动添加，但自动添加的部分不需要包含数字。"
        Else
            Sheets("账套基础信息表").Cells(20, 3).Value = TextBox1.Text
    End If
    
End Sub


Private Sub UserForm_Activate()
    CommandButton1.SetFocus
    
    
End Sub
Private Sub UserForm_Initialize()

    With Sheets("账套基础信息表")
        If .Cells(20, 3).Value = "" Then
                TextBox1.Text = "记-"
            Else
            
                TextBox1.Text = .Cells(20, 3).Text
        End If
    End With

 
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     If Cells(3, 2).Value = "" Or Cells(3, 2).Value = 1 Then
         Cells(3, 2).Value = TextBox1.Text & "1"
     End If
    
End Sub

Attribute VB_Name = "UserForm31"
Attribute VB_Base = "0{1B163A61-9B6D-40A2-8A39-46CF7C7033EB}{EC9EA4B2-FF34-40A4-9875-C5D6072AF03A}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub CommandButton1_Click()
    Unload Me
End Sub

Attribute VB_Name = "模块7"
 
Sub 宏9()
Attribute 宏9.VB_ProcData.VB_Invoke_Func = " \n14"

 





    Application.ScreenUpdating = False
    For x = 1 To 94
        Rows("16:30").Copy
        Cells(31, 1).Insert Shift:=xlDown
    Next
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    
End Sub



Sub hanggaotiaojie()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板")
        For i = 0 To 95
            
            For x = 5 To 11
                
                rx = i * 15 + x
                .Rows(rx & ":" & rx).RowHeight = 31.2
            
            Next
            
        Next
        
    End With
    
    
    
    
End Sub


Sub huanhang()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板06")
        For i = 0 To 95
          
            
            With .Range(.Cells(i * 18 + 14, 2), .Cells(i * 18 + 14, 2))
                .WrapText = True
            End With
        Next
        
    End With
    
    
    
    
End Sub

Sub hanggaotiaojie02()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板02")
        For i = 0 To 95
            For x = 5 To 11
                rx = i * 15 + x
                If x = 5 Or x = 11 Then
                        .Rows(rx & ":" & rx).RowHeight = 30.6
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 31.2
                End If
            Next
        Next
    End With
End Sub



Sub hanggaotiaojie03()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板03")
        For i = 0 To 95
            For x = 5 To 14
                rx = i * 18 + x
                If x = 5 Or x = 14 Then
                        .Rows(rx & ":" & rx).RowHeight = 28.8
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 29.4
                End If
            Next
        Next
    End With
    
End Sub



Sub hanggaotiaojie04()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板04")
        For i = 0 To 95
            For x = 5 To 11
                rx = i * 15 + x
                If x = 5 Or x = 11 Then
                        .Rows(rx & ":" & rx).RowHeight = 27.6
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 30
                End If
            Next
        Next
    End With
    
End Sub


Sub hanggaotiaojie05()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板05")
        For i = 0 To 143
            For x = 5 To 11
                rx = i * 15 + x
                .Rows(rx & ":" & rx).RowHeight = 24.6
            Next
        Next
    End With
    
End Sub



Sub hanggaotiaojie06()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板06")
        For i = 0 To 95
             
            For x = 5 To 14
                rx = i * 18 + x
                
                If x = 5 Or x = 14 Then
                        .Rows(rx & ":" & rx).RowHeight = 28.8
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 29.4
                End If
            Next
            
        Next
    End With
    
End Sub



Attribute VB_Name = "Sheet9"
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 = "Sheet27"
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
    
    
    Public x1 As Double
    Public x2 As Double
    Public x3 As Double
    Public x4 As Double
    Public x5 As Double
    Public x6 As Double
    
    Public dm1 As Long
    Public jc As Long
    
     
     
Private Sub Worksheet_Activate()
    Application.ScreenUpdating = False

    On Error Resume Next
 

    
    Application.MoveAfterReturnDirection = xlToRight
    
    
    With Range("A:A,B:B,V:V,X:X,Z:Z")
        .NumberFormatLocal = "0_ "
    End With
    
    
    Dim p4 As Integer
    p4 = 0
    
    With Sheets("账套基础信息表")
        If .Cells(54, 3).Value <> "" Then
            p4 = .Cells(54, 3).Value
        End If
    End With
    
    If p4 = 20 Then
        Columns("H:H").ColumnWidth = 0
        Columns("M:O").ColumnWidth = 0
        Columns("W:Z").ColumnWidth = 0
    End If
        
    If p4 = 10 Then
        Columns("H:H").ColumnWidth = 0
        Columns("M:O").ColumnWidth = 0
        Columns("W:Y").ColumnWidth = 0
    End If
        
    If p4 = 0 Then
        Columns("H:H").ColumnWidth = 0
        Columns("M:O").ColumnWidth = 0
        Columns("W:W").ColumnWidth = 0
        Columns("Y:Y").ColumnWidth = 0
    End If
    
    Application.ScreenUpdating = True

End Sub
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    
    Call youjiancaidan03
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim r As Integer
    r = Target.Row
    On Error Resume Next
    If r < 3 Then Exit Sub
    
    If Target.Column = 1 Then
        If Cells(r, 1).Value = "" Then
            Cells(r, 2).Value = ""
            Exit Sub
        End If
        
                              
        
        
         If VBA.Int(VBA.Val(VBA.Len(Cells(r, 1).Value) / 2 - 1)) <> VBA.Len(Cells(r, 1).Value) / 2 - 1 Or VBA.Len(Cells(r, 1).Value) / 2 - 1 > 6 Or VBA.Len(Cells(r, 1).Value) / 2 - 1 < 1 Then
                                                                                                
                                                                                                
            MsgBox "异常提示：" & vbCrLf & "    第一列最新输入的科目代码的长度可能有问题，科目代码请按以下规则输入：一级科目总长4位，二级科目总长6位，三级科目总长8位，" _
                    & "四级科目总长10位，五级科目总长12位，六级科目总长14位。科目级次最大为六级。"
            Exit Sub
        End If
        
        
        Cells(r, 2).Value = VBA.Len(Cells(r, 1).Value) / 2 - 1
        
        
        If Cells(r, 2).Value > 1 Then
            For i = r To r - 800 Step -1
                If r = 3 Then Exit For
                
                If VBA.Len(Cells(i, 1).Value) / 2 - 1 = 1 And VBA.Left(Cells(r, 1).Text, 4) = VBA.Left(Cells(i, 1), 4) Then
                    Application.EnableEvents = False
                    Cells(r, 4).Value = Cells(i, 4).Value
                    Application.EnableEvents = True
                End If
            Next
        End If
        
        If Cells(r, 2).Value = 1 Then
            If Cells(r, 1).Value <= 1012 Then
                MsgBox "系统提示：根据本财务系统设置规则，科目代码开头四位为1012或以下的科目，本财务软件自动默认为货币资金类会计科目，在自动分析填报现金流量表时，视同货币资金类科目。科目代码开关四位大于1012的，本软件默认视为非货币资金类科目，不在现金流量表的统计范围内，新增会计科目时请知晓此规则。"
                Exit Sub
            End If
        End If
        
        
        If VBA.Len(Cells(r, 1).Value) / 2 - 1 > 1 And VBA.Len(Cells(r, 1).Value) / 2 - 1 >= VBA.Len(Cells(r - 1, 1).Value) / 2 - 1 Then
            If VBA.Len(Cells(r, 1).Value) / 2 - 1 > VBA.Len(Cells(r - 1, 1).Value) / 2 - 1 Then
                    If VBA.str(VBA.Left(Cells(r, 1).Value, VBA.Len(Cells(r, 1).Value) - 2)) <> VBA.str(Cells(r - 1, 1).Value) Then
                        MsgBox "异常提示：" & vbCrLf & "    新增加科目与上行科目之间位置顺序或隶属关系异常，请检查。"
                        Exit Sub
                    End If
                Else
                    If VBA.Left(Cells(r, 1).Value, VBA.Len(Cells(r, 1).Value) - 2) <> VBA.Left(Cells(r - 1, 1).Value, VBA.Len(Cells(r - 1, 1).Value) - 2) Then
                        MsgBox "异常提示：" & vbCrLf & "    新增加科目与上行科目的上级科目应一致，此处不一致，异常请检查。"
                        Exit Sub
                    End If
            End If
        End If
                
        

        On Error Resume Next
        Application.ScreenUpdating = False
        Cells.ClearOutline
        For i = 1 To 5
            ActiveSheet.Rows("1:4000").Ungroup
        Next
        
        
        For i = 3 To 4000
            If Cells(i + 1, 1).Value = "" Then Exit For
            If VBA.Len(Cells(i + 1, 1).Value) <= VBA.Len(Cells(i, 1).Value) Then GoTo a800
            For ii = i + 1 To 2000
                If VBA.Len(Cells(ii + 1, 1).Value) <= VBA.Len(Cells(i, 1).Value) Then Exit For
            Next
            Rows(i + 1 & ":" & ii).Group
a800:
        Next
        Application.ScreenUpdating = True
    End If



           

    Select Case Target.Column
    
        Case 3
            Range(Cells(r, 3), Cells(r, 3)).IndentLevel = Cells(r, 2).Value - 1
        Case 4
            If Target.Count > 1 Then Exit Sub
            
            
            If Target.Value <> "" Then
                
                  
                
                
                If r > 3 And Cells(r, 1).Value <> "" And Cells(r - 1, 1).Value <> "" Then
                    If VBA.Left(Cells(r, 1).Value, 4) = VBA.Left(Cells(r - 1, 1).Value, 4) And VBA.Left(Cells(r, 4).Value, 3) <> VBA.Left(Cells(r - 1, 4).Value, 3) Then
                        
                        
                        MsgBox "错误提示： 当前选择的科目类别与上行科目类别不同，请重新选择。注意相同一级科目下的明细科目的科目类别应相同。"
                        Application.EnableEvents = False
                        Target = ""
                        Application.EnableEvents = True
                        Exit Sub
                    End If
                End If
        
        
                
                
                If Target.Value <> "资产类" And Target.Value <> "负债类" And Target.Value <> "净资产类" And Target.Value <> "事业收入类" And Target.Value <> "经营收入类" _
                    And Target.Value <> "事业支出类" And Target.Value <> "经营支出类" And Target.Value <> "权益类" And Target.Value <> "成本类" And Target.Value <> "损益类" _
                    And Target.Value <> "损益类（限定性）" Then
                
                    MsgBox "录入值不合规，请重新录入或重新选择当前位置后使用下拉菜单选择"
                    Target.Value = ""
                    Exit Sub
                End If
                
                With Target.Validation
                    .Delete
                End With
                
            End If
            
            
            
            If Target.Value = "" And Cells(r, 1).Value <> "" Then
            
                With Target.Validation
                    .Delete
                    
                    If Sheets("账套基础信息表").Cells(54, 3).Value = 20 Or ActiveSheet.Name = "科目设置表模板20" Then
                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="资产类,负债类,净资产类,事业收入类,经营收入类,事业支出类,经营支出类"
                        Else
                            If Sheets("账套基础信息表").Cells(54, 3).Value = 10 Or ActiveSheet.Name = "科目设置表模板10" Then
                                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="资产类,负债类,权益类,成本类,损益类,损益类（限定性）"
                                Else
                                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="资产类,负债类,权益类,成本类,损益类"
                            End If
                    End If
                    .IgnoreBlank = True
                    .ShowError = False
                End With
            End If
            
            
        Case 5
            If Target.Count = 1 Then
                If Target.Value <> "" Then
                    With Target.Validation
                        .Delete
                    End With
                End If
                If Target.Value <> "" Then
                    If Target.Value <> "借" And Target.Value <> "贷" Then
                        MsgBox "录入值不合规，请重新录入或重新选择当前位置后使用下拉菜单选择"
                        Target.Value = ""
                    End If
                End If
                
                
                If Target.Value = "" And Cells(r, 1).Value <> "" Then
                    With Target.Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="借,贷"
                        .IgnoreBlank = True
                        .ShowError = False
                    End With
                    
                End If
                
                
            End If
            
        Case 6, 11

            
            If Target.Count = 1 Then
                If Target <> "" Then
                    If Target <> "是" Then
                            MsgBox " 提示：当前位置只能录入 是 或不录入，请勿录入其他内容。"
                            Target = ""
                            GoTo a228
                        Else
                            With Target.Validation
                                .Delete
                            End With
                    End If
                End If
            End If

            
            If Cells(r, Target.Column).Value = "是" Then
                If Target.Column = 6 Then
                        Sheets("凭证表").Columns("M:M").EntireColumn.Hidden = False
                        Sheets("科目设置表").Columns("G:G").EntireColumn.Hidden = False
                    Else
                        
                            
                            If Sheets("凭证表").Columns("J:J").ColumnWidth < 8 Then Sheets("凭证表").Columns("J:J").ColumnWidth = 10
                            If Sheets("凭证表").Columns("K:K").ColumnWidth < 8 Then Sheets("凭证表").Columns("K:K").ColumnWidth = 10
                            If Sheets("凭证表").Columns("L:L").ColumnWidth < 6 Then Sheets("凭证表").Columns("L:L").ColumnWidth = 8
                              
                        
                        
                        
                        If Sheets("科目设置表").Columns("L:L").ColumnWidth < 6 Then Sheets("科目设置表").Columns("L:L").ColumnWidth = 7
                End If
            End If
            
            
            For i = r + 1 To 5000
                If Cells(i, 1).Value = "" Then Exit For
                If VBA.Len(Cells(i, 1).Value) > VBA.Len(Cells(r, 1).Value) And VBA.Left(VBA.str(Cells(i, 1).Value), VBA.Len(VBA.str(Cells(r, 1).Value))) = VBA.str(Cells(r, 1).Value) Then
                    Application.EnableEvents = False
                    If Cells(r, Target.Column).Value = "是" Then
                            Cells(i, Target.Column).Value = "是"
                        Else
                            
                    End If
                    Application.EnableEvents = True
                End If
            Next
a228:
            
        Case 7
            
            
            
            For i = r + 1 To 5000
                If Cells(i, 1).Value = "" Then Exit For
                If VBA.Len(Cells(i, 1).Value) > VBA.Len(Cells(r, 1).Value) And VBA.Left(VBA.str(Cells(i, 1).Value), VBA.Len(VBA.str(Cells(r, 1).Value))) = VBA.str(Cells(r, 1).Value) Then
                    Application.EnableEvents = False
                    If Cells(r, Target.Column).Value <> "" And Cells(i, Target.Column - 1).Value = "是" Then
                            Cells(i, Target.Column).Value = Cells(r, Target.Column).Value
                        Else
                            
                    End If
                    Application.EnableEvents = True
                End If
            Next
            
        Case 12
            
        Case 16, 17
            If r < 3 Then Exit Sub
            
            
            
            
            
            
            
            
            
            Application.EnableEvents = False
            
            x1 = 0: x2 = 0: x3 = 0: x4 = 0: x5 = 0: x6 = 0: jc = 0
            dm1 = VBA.Left(Cells(r, 1).Value, 4)
            
            If Cells(r, 16).Value <> "" And Cells(r, 16).Value <> 0 Then
                If Cells(r, 5).Value <> "借" Then
                        Target = ""
                        Cells(r, 16).Select
                        MsgBox "提示： 当前科目的余额方向不是借，请按余额方向在正确的位置填写期初余额。"
                        Application.EnableEvents = True
                        Exit Sub
                    Else
                        Application.EnableEvents = False
                        Cells(r, 17).Value = ""
                End If
            End If
            
            If Cells(r, 17).Value <> "" Or Cells(r, 17).Value <> 0 Then
                If Cells(r, 5).Value <> "贷" Then
                        Target = ""
                        Cells(r, 17).Select
                        MsgBox "提示： 当前科目的余额方向不是借，请按余额方向在正确的位置填写期初余额。"
                        Application.EnableEvents = True
                        Exit Sub
                    Else
                        Cells(r, 16).Value = ""
                End If
            End If
            
            
                    
                
            
            
            If VBA.Len(Cells(r, 1).Text) < VBA.Len(Cells(r + 1, 1).Text) Then
                Application.EnableEvents = False
                Target.Value = ""
                Target.Select
                MsgBox "提示： 请不要在非末级科目中录入余额，如果有下级科目，请直接在下级科目中录入，上级科目会自动合计更新。"
                
                
                
                
                Dim x09 As Integer
                x09 = Cells(r + 1, 2).Value
                Dim huizong09 As Double
                For i = r + 1 To r + 4000
                    If Cells(i, 2).Value < x09 Then Exit For
                    If Cells(i, 2).Value > x09 Then GoTo a0915
                    huizong09 = huizong09 + Cells(i, 16).Value - Cells(i, 17).Value
a0915:
                Next
                If Cells(r, 5).Value = "借" Then
                        Target.Value = huizong09
                    Else
                        Target.Value = huizong09 * (-1)
                End If
                
                
                
                
                Application.EnableEvents = True
                
                
                
                Exit Sub
            End If
            
            
            
            For i = 5000 To 3 Step -1
                If Cells(i, 1) = "" Then GoTo a880
                If Val(VBA.Left(Cells(i, 1).Value, 4)) <> dm1 Then GoTo a880
                
                Select Case VBA.Len(Cells(i, 1).Value) / 2 - 1
                    Case 1
                        If jc = 0 Then
                                Application.EnableEvents = True
                                Exit Sub
                            Else
                                If Cells(i, 5).Value = "借" Then
                                        If x2 <> 0 Then
                                                Cells(i, 16).Value = x2
                                            Else
                                                Cells(i, 16).Value = ""
                                        End If
                                        Cells(i, 17).Value = ""
                                    Else
                                        If x2 <> 0 Then
                                                Cells(i, 17).Value = -x2
                                            Else
                                                Cells(i, 17).Value = ""
                                        End If
                                        Cells(i, 16).Value = ""
                                End If
                        End If
                    Case 2
                        
                        If jc = 3 Then
                                If Cells(i, 5).Value = "借" Then
                                        If x3 <> 0 Then
                                                Cells(i, 16).Value = x3
                                            Else
                                                Cells(i, 16).Value = ""
                                        End If
                                        Cells(i, 17).Value = ""
                                    Else
                                        If x3 <> 0 Then
                                                Cells(i, 17).Value = -x3
                                            Else
                                                Cells(i, 17).Value = ""
                                        End If
                                        Cells(i, 16).Value = ""
                                End If
                                x2 = x2 + x3
                                x3 = 0
                            Else
                                x2 = x2 + Cells(i, 16).Value - Cells(i, 17).Value
                        End If
                        jc = 2
                    Case 3
                        If jc = 4 Then
                                If Cells(i, 5).Value = "借" Then
                                        If x4 <> 0 Then
                                                Cells(i, 16).Value = x4
                                            Else
                                                Cells(i, 16).Value = ""
                                        End If
                                        Cells(i, 17).Value = ""
                                    Else
                                        If x4 <> 0 Then
                                                Cells(i, 17).Value = -x4
                                            Else
                                                Cells(i, 17).Value = ""
                                        End If
                                        Cells(i, 16).Value = ""
                                End If
                                x3 = x3 + x4
                                x4 = 0
                            Else
                                x3 = x3 + Cells(i, 16).Value - Cells(i, 17).Value
                        End If
                        jc = 3
                        
                        
                   Case 4
                        
                        If jc = 5 Then
…
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 1674240 bytes
SHA-256: c9f9adeabcad0dfb97ecea8c6056fbaec975f9649978efbd0fd326d7bddf79cb
emf_00.emf ooxml-emf OOXML EMF part: xl/media/image5.emf 1496 bytes
SHA-256: afe9efbb457d6e720129196c90030948ec980c85abfb7e4d898752cc27961749
emf_01.emf ooxml-emf OOXML EMF part: xl/media/image1.emf 1496 bytes
SHA-256: c218e31b68cede5fee72087a718dba86912e7645e44af7fdf758f46fdad5934f
emf_02.emf ooxml-emf OOXML EMF part: xl/media/image2.emf 496 bytes
SHA-256: 47b0c8939cf247771b414c7250b6b1fde5542620036d2a73177bd1c870e52df2

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