1,488
社区成员
![](https://csdnimg.cn/release/cmsfe/public/img/topic.427195d5.png)
![](https://csdnimg.cn/release/cmsfe/public/img/me.40a70ab0.png)
![](https://csdnimg.cn/release/cmsfe/public/img/task.87b52881.png)
![](https://csdnimg.cn/release/cmsfe/public/img/share-circle.3e0b7822.png)
Dim A As String, LastCell As Range, ThisCell As Range
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Dim R, C As Integer
Cancel = True
If Target.Cells(1) = "" Then Exit Sub
R = Target.Row
C = Target.Column
If R = 1 Then
Select Case C
Case 1
Call Initialize
Case 2
Call Show_Level
Case 3
Call Unite_Direction
Target.Select
Case 5
If [KYB] Then
Call Import_KYB
End If
Case 8
Call Absolute_Balance
Target.Select
End Select
Exit Sub
End If
Select Case C
Case 1
Call Select_Vouchers(Target)
Case 2
Application.ScreenUpdating = False
If [B1] = "科目全称" Then Call Change_Full_Name
With Me
.AutoFilterMode = False
While .Cells(R, 14) > 1
R = R - 1
Wend
Me.Range("A1:O1").AutoFilter
With Me.Cells(1)
.AutoFilter Field:=13, Criteria1:=Me.Cells(R, 13) & "*"
End With
End With
If Application.WorksheetFunction.CountIf(Sheet5.Range("A:A"), Target.Offset(0, -1).Value) > 0 Then
With Sheet5
.AutoFilterMode = False
.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=Target.Offset(0, -1).Value
.Select
End With
End If
Application.ScreenUpdating = True
End Select
End Sub
Private Sub Import_KYB()
On Error Resume Next
Dim WB As Workbook, SH As Worksheet, CC As Long, R As Range
With Import
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.FilterIndex = 3
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Me.AutoFilterMode = False
Me.UsedRange.Offset(1, 0).EntireRow.Delete
Set WB = Workbooks.Open(.SelectedItems(1), False, True)
End With
ThisWorkbook.Names("SFN").RefersTo = "=""" & WB.FullName & """"
Set SH = WB.ActiveSheet
CC = SH.UsedRange.Columns.Count
RC = SH.UsedRange.Rows.Count
ThisWorkbook.Activate
.Visible = xlSheetVisible
.Rows("3:14").ClearContents
.Rows("3:14").Cells.UnMerge
.Cells(1, 2) = "科目余额表"
.Cells(1, 6).Value = 2
.Cells(1, 9).Value = RC
.Cells(3, 1).Value = "行 号"
For i = 1 To 5
.Cells(i + 3, 1) = i
.Cells(i + 8, 1) = i + 5
.Cells(i + 14, 1) = RC + i - 5
Next i
SH.Range(SH.Cells(1, 1), SH.Cells(10, CC)).Copy .Cells(4, 2)
.Range(.Cells(14, 1), .Cells(14, CC + 1)).Value = "⋯⋯"
SH.Range(SH.Cells(RC - 4, 1), SH.Cells(RC, CC)).Copy .Cells(15, 2)
.Range("A4:A19").HorizontalAlignment = xlCenter
.Range(.Cells(4, 2), .Cells(19, CC + 1)).Style = "Normal"
For Each R In .Range(.Cells(4, 2), .Cells(4, CC + 1))
With R.Offset(-1, 0)
.Validation.Delete
.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="科目代码,科目名称,期初方向,期初数量,期初余额,期初借方," & _
"期初贷方,本期借方,本期贷方,期末方向,期末数量,期末余额,期末借方,期末贷方"
.Validation.ErrorMessage = "请从下拉列表中选择。"
.Style = "表头"
End With
Select Case Trim(R)
Case "科目代码", "科目编码", "科目编号", "科目代号"
R.Offset(-1, 0) = "科目代码"
Case "科目名称"
R.Offset(-1, 0) = "科目名称"
Case "期初方向"
R.Offset(-1, 0) = "期初方向"
Case "期初余额", "期初金额"
R.Offset(-1, 0) = "期初余额"
Case "期初借方余额", "期初借方", "期初借方金额"
R.Offset(-1, 0) = "期初借方"
Case "期初贷方余额", "期初贷方", "期初贷方金额"
R.Offset(-1, 0) = "期初贷方"
Case "本年借方累计", "本期发生借方", "累计借方金额", "本期借方金额", "本期借方累计", "借方累计"
R.Offset(-1, 0) = "本期借方"
Case "本年贷方累计", "本期发生贷方", "累计贷方金额", "本期贷方金额", "本期贷方累计", "贷方累计"
R.Offset(-1, 0) = "本期贷方"
Case "期末方向"
R.Offset(-1, 0) = "期末方向"
Case "期末余额", "期末金额"
R.Offset(-1, 0) = "期末余额"
Case "期末借方余额", "期末借方", "期末借方金额"
R.Offset(-1, 0) = "期末借方"
Case "期末贷方余额", "期末贷方", "期末贷方金额"
R.Offset(-1, 0) = "期末贷方"
Case "期初数量"
R.Offset(-1, 0) = "期初数量"
Case "期末数量"
R.Offset(-1, 0) = "期末数量"
Case "方向"
If Application.WorksheetFunction.CountIf(.Range(.Cells(4, 1), R.Offset(0, -1)), "方向") = 0 Then
R.Offset(-1, 0) = "期初方向"
Else
R.Offset(-1, 0) = "期末方向"
End If
Case Else
R.Offset(-1, 0).Style = "输入"
End Select
Next R
WB.Close False
Application.Goto .Cells(1, 11)
End With
End Sub
Private Sub Unite_Direction()
On Error Resume Next
Dim RC As Long, FO() As Boolean, FC() As String, AFM As Boolean
RC = Me.UsedRange.Rows.Count
If RC < 2 Then Exit Sub
Application.Calculation = xlCalculationManual
For i = 2 To RC
Select Case Left(Cells(i, 1), 1)
Case 1, 3, 5
Cells(i, 3) = IIf(Cells(i, 11) = 0, "平", "借")
Cells(i, 5) = Cells(i, 11)
Cells(i, 8) = IIf(Cells(i, 12) = 0, "平", "借")
Cells(i, 10) = Cells(i, 12)
Case 2, 4
Cells(i, 3) = IIf(Cells(i, 11) = 0, "平", "贷")
Cells(i, 5) = -Cells(i, 11)
Cells(i, 8) = IIf(Cells(i, 12) = 0, "平", "贷")
Cells(i, 10) = -Cells(i, 12)
End Select
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub Absolute_Balance()
On Error Resume Next
RC = Me.UsedRange.Rows.Count
If RC < 3 Then Exit Sub
Application.Calculation = xlCalculationManual
For i = 3 To RC
Cells(i, 3) = IIf(Cells(i, 11) = 0, "平", IIf(Cells(i, 11) > 0, "借", "贷"))
Cells(i, 5) = Abs(Cells(i, 11))
Cells(i, 8) = IIf(Cells(i, 12) = 0, "平", IIf(Cells(i, 12) > 0, "借", "贷"))
Cells(i, 10) = Abs(Cells(i, 12))
If Left(Cells(i, 1), 1) = 5 Then Exit For
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub Show_Level()
On Error Resume Next
Dim R As Range, X As String, T As String
On Error Resume Next
X = vbCr: T = vbTab
X = InputBox("输入功能代码(n∈[2,9]):" & X & X & _
"1" & T & "显示到全部科目" & X & _
"n" & T & "显示到 1~n 级科目" & X & _
"-n" & T & "只显示第 n 级科目" & X & _
"0" & T & "切换科目全名\名称" & X & _
"-" & T & "只显示明细科目" & _
"")
RC = Me.UsedRange.Rows.Count
With Me.Range("A1:O1")
Select Case X
Case 1
If Me.Range("B1") = "科目全称" Then
Call Change_Full_Name
End If
.AutoFilter Field:=14
.AutoFilter Field:=15
Case 2 To 9
.AutoFilter Field:=14, Criteria1:="<=" & X
.AutoFilter Field:=15
Case -2 To -9
.AutoFilter Field:=14, Criteria1:="=" & Abs(X), Operator:=xlOr, Criteria2:="=1", VisibleDropDown:=True
.AutoFilter Field:=15
Case 0
.AutoFilter Field:=15
Call Change_Full_Name
Case "-", "-", "—"
If Me.AutoFilter.Filters(15).On Then
If Me.AutoFilter.Filters(15).Criteria1 = "=1" Then
.AutoFilter Field:=15
Else
.AutoFilter Field:=15, Criteria1:="=1"
End If
Else
.AutoFilter Field:=15, Criteria1:="=1"
End If
Case Else
Exit Sub
End Select
End With
End Sub
Private Sub Change_Full_Name()
On Error Resume Next
Application.ScreenUpdating = False
With Me
.Range("B:B").Cut .Range("Z1")
.Range("M:M").Cut .Range("B1")
.Range("Z:Z").Cut .Range("M1")
.Columns(2).ColumnWidth = 60
.Columns(13).Hidden = True
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Sub Select_Vouchers(Target As Range)
With Sheet2
.AutoFilterMode = False
While Application.WorksheetFunction.CountIf(.Columns(1), Target.Text & "*") = 0
Set Target = Target.Offset(-1, 0)
Wend
.Range("A1:K1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:="=" & Target.Value & "*"
.Cells(1).AutoFilter Field:=3 ', VisibleDropDown:=False
.Cells(1).AutoFilter Field:=4 ', VisibleDropDown:=False
.Cells(1).AutoFilter Field:=11 ', VisibleDropDown:=False
ThisWorkbook.Names.Add "Selected", "=" & Target.Address, False
.Columns("H:H").Hidden = (.[H1] = 0)
.Columns("I:J").Hidden = True
Application.Goto .Cells(1, 1), True
.Activate
End With
If Application.WorksheetFunction.CountIf(Sheet5.[A:A], Target) > 0 Then
With Sheet5
.Visible = xlSheetVisible
.AutoFilterMode = False
.Range("A1:M1").AutoFilter
.Range("A1").AutoFilter Field:=1, Criteria1:=Target
Application.Goto .[A1]
End With
End If
End Sub
On Error Resume Next
If Not ThisCell Is Nothing Then Set ThisCell = Target.CE
Set LastCell = ThisCell
Set ThisCell = Target.Cells(1)
If Target.Cells.Count > 1 Then Target.Copy Else Application.CutCopyMode = False
End Sub
Private Sub Initialize()
On Error Resume Next
Application.ScreenUpdating = False
Me.AutoFilterMode = False
Me.Range("A1:O1").AutoFilter
With Me.Cells(1, 1)
.AutoFilter Field:=14, Criteria1:="1"
For i = 1 To 11
.AutoFilter Field:=i, VisibleDropDown:=False
Next i
End With
For i = 1 To 14
Me.Columns(i).ColumnWidth = Array(15, 60, 2, 0, 15, 15, 15, 2, 0, 15, 0, 0, 0, 0)(i - 1)
Next i
'Me.Columns("K:N").Hidden = True
Application.ScreenUpdating = True
End Sub