Excel 实战

最新推荐文章于 2023-09-01 16:17:21 发布
最新推荐文章于 2023-09-01 16:17:21 发布
阅读量494 收藏
点赞数 1
分类专栏： Excel VB 技巧
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/moscot_wu/article/details/96320117
版权 
Sub Findblankrange(str As String, end_row As Integer, start_row As Integer)
    Dim rng
    'Dim i As Integer
    'Dim lr As Integer
   ' On Error Resume Next
'lr = ActiveSheet.UsedRange.Rows.Count
Set rng = ActiveSheet.UsedRange.Find(str)
start_row = rng.row
'MsgBox start_row
end_row = ActiveSheet.Range("A" & start_row).End(xlDown).row + 1 'the first blank after
'MsgBox end_row
'For i = start_row To lr + 1
'If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
'end_row = i
'Exit For
'End If
'Next i
End Sub

Sub Findfirstblankrow(rown As Integer)
    Dim i As Integer
    On Error Resume Next
For i = 28 To 58
'Set myRange = Worksheets("Input Form").Range("A" & i & ":G" & i)
If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
rown = i
'MsgBox "No Value, in " & rown
Exit For
End If
Next
End Sub
Sub Findsecondblankrow(spe_row As Integer, n As Integer)
    Dim k As Integer
    Dim m As Integer
    On Error Resume Next
For k = 31 To 71
If ActiveSheet.Range("A" & k) = "REFER_CTRY_REPORTS_REL" Then
n = k + 1
For m = n To n + 40
If Application.WorksheetFunction.CountA(Rows(m)) = 0 Then
spe_row = m
Exit For
End If
Next m

Exit For
End If
Next k
End Sub

Sub Findthirdblankrow(spe_row As Integer, n As Integer)
    Dim k As Integer
    Dim m As Integer
    On Error Resume Next
For k = 34 To 74
If ActiveSheet.Range("A" & k) = "REFER_CTRY_FF_REPORTS_REL" Then
n = k + 1
For m = n To n + 40
If Application.WorksheetFunction.CountA(Rows(m)) = 0 Then
spe_row = m
Exit For
End If
Next m
Exit For
End If
Next k
End Sub

'This is copy and past value only
Sub past()
Dim row_1 As Integer
row_1 = Sheets("REFER_REPORTS").UsedRange.Rows.Count + 1
    Worksheets("Input Form").Range("A26:M26").Copy
    Worksheets("REFER_REPORTS").Range("A" & row_1).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = xlCut
End Sub
Sub past5()
Dim row_1 As Integer
row_1 = Sheets("REFER_REPORTS").UsedRange.Rows.Count + 1
    Worksheets("Input Form").Range("A27:M27").Copy
    Worksheets("REFER_REPORTS").Range("A" & row_1).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = xlCut
End Sub

Sub past2()
Dim row_2 As Integer
Dim ft As Integer
row_2 = Sheets("RPT_ELEM_REL").UsedRange.Rows.Count + 1
Call Findfirstblankrow(ft)
Worksheets("Input Form").Range("A31:F" & ft - 1).Copy
Worksheets("RPT_ELEM_REL").Range("A" & Rows.Count + 1).PasteSpecial (xlPasteValues)
Application.CutCopyMode = xlCut
End Sub

Sub past3()
Dim row_3 As Integer
Dim k As Integer
Dim m As Integer
row_3 = Sheets("REFER_CTRY_REPORTS_REL").UsedRange.Rows.Count + 1
Call Findsecondblankrow(m, k)
Worksheets("Input Form").Range("A" & k + 1 & ":E" & m - 1).Copy
Worksheets("REFER_CTRY_REPORTS_REL").Range("A" & row_3).PasteSpecial (xlPasteValues)
Application.CutCopyMode = xlCut
End Sub
Sub past4()
Dim row_4 As Integer
Dim k As Integer
Dim m As Integer
row_4 = Sheets("REFER_CTRY_FF_REPORTS_REL").UsedRange.Rows.Count + 1
Call Findthirdblankrow(m, k)
Worksheets("Input Form").Range("A" & k + 1 & ":F" & m - 1).Copy
Worksheets("REFER_CTRY_FF_REPORTS_REL").Range("A" & row_4).PasteSpecial (xlPasteValues)
Application.CutCopyMode = xlCut
End Sub
Sub Alloff()
Dim i As Integer
For i = 1 To 27
ActiveSheet.OLEObjects("CheckBox" & i).Object.Value = 0
Next
ActiveSheet.OLEObjects("CheckBox93").Object.Value = 0
ActiveSheet.OLEObjects("CheckBox94").Object.Value = 0
End Sub
Sub Allon()
Dim i As Integer
For i = 1 To 27
ActiveSheet.OLEObjects("CheckBox" & i).Object.Value = 1
Next
ActiveSheet.OLEObjects("CheckBox93").Object.Value = 1
ActiveSheet.OLEObjects("CheckBox94").Object.Value = 1
End Sub

Sub Addnewline2(st As String, n As Integer)
'Updateby Extendoffcie 20161129
    Dim Response
    Dim str As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Input Form")
    Response = vbYes
    'MsgBox Response
    Do While Response = vbYes
    If Response = vbYes Then
    str = InputBox("Please input BIS_TRAN_FILE_FORMT_CD.", "BIS_TRAN_FILE_FORMT_CD")
    With ws
    .Range("A" & n).EntireRow.Insert
    .Range("A" & n) = "N/A"
    .Range("A" & n & ":B" & n).Merge
    .Range("C" & n) = st
    .Range("D" & n) = str
    .Range("D" & n & ":E" & n).Merge
    .Range("F" & n).Formula = "=E3"
    End With
    'Response = MsgBox("Do you want add new one?", vbYesNo, "Add new ")
    End If
    Response = MsgBox("Do you want to add a new one?", vbYesNo, "Add new one")
    Loop
End Sub

'Cancel all selected CheckBox
Sub clearcheckbox()
'Updateby Extendoffcie 20161129
    Dim c As Object
    For Each c In ActiveSheet.OLEObjects
        If InStr(1, c.Name, "CheckBox") > 0 Then
            c.Object.Value = False
        End If
    Next
End Sub

Sub Addnewline(st As String, n As Integer)

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Input Form")
    'MsgBox Response
    'Call Findfirstblankrow(n)
    With ws
    .Range("A" & n).EntireRow.Insert
    .Range("A" & n) = "N/A"
    .Range("B" & n).Formula = "=E2"
    .Range("C" & n) = st
    .Range("C" & n & ":D" & n).Merge
    .Range("E" & n) = ""
    .Range("F" & n).Formula = "=E21"
    .Range("F" & n & ":G" & n).Merge
    End With
End Sub

Sub Addnewline1(st As String, n As Integer)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Input Form")
    'MsgBox Response
    'Call Findfirstblankrow(n)
    With ws
    .Range("A" & n).EntireRow.Insert
    .Range("A" & n) = "N/A"
    .Range("A" & n & ":B" & n).Merge
    .Range("C" & n) = st
    .Range("D" & n).Formula = "=E9"
    .Range("E" & n).Formula = "=E3"
    End With
End Sub

Sub Delline(st As String, n As Integer, m As Integer)
'Updateby Extendoffcie 20161129
    Dim Response
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Input Form")
    'Dim m As Integer
    'Dim n As Integer
    'Call Findthirdblankrow(n, m)
    'MsgBox m & n
    For i = n To m Step -1
    If ws.Range("C" & i) = st Then
    ws.Range("A" & i + 1).Offset(-1, 0).EntireRow.Delete
    End If
    Next
End Sub

Function lastline(str As String) As Integer
'Updateby Extendoffcie 20161129
    Dim n As Integer
    n = Sheet(str).UsedRange.Rows.Count
    lastline = n
End Function

Sub Findstr(str As String, k As Integer)
k = ActiveSheet.UsedRange.Find(str).row
MsgBox k
End Sub


'Sub GetOption()
'Dim x As Integer, i As Integer
'Dim TempForm As Access.Module
'Set objModule = Application.Modules.Item(Application.VBE.ActiveCodePane.CodeModule.Parent.Name)
'Dim WSheet As Worksheet
'With ActiveSheet.CheckBox
'For i = 98 To 99
'With TempForm.CodeModule
'x = .CountOfLines
'.InsertLines x + 1, "Private Sub CheckBox" & i & "_Click()"
'.InsertLines x + 2, " Dim n As Integer,st As String"
'.InsertLines x + 3, " st = Me.CheckBox" & i & ".Caption"
'.InsertLines x + 4, " With Me.CheckBox" & i
'.InsertLines x + 5, " Call Findfirstblankrow(n)"
'.InsertLines x + 6, " .Value Then"
'.InsertLines x + 7, " Me.Range(""A"" & n).EntireRow.Insert"
'.InsertLines x + 8, " Me.Range(""A"" & n) = ""N/A"""
'.InsertLines x + 9, " Me.Range(""B"" & n) = Me.Range(""E2"")"
'.InsertLines x + 10, " Me.Range(""C"" & n) = st"
'.InsertLines x + 11, " Me.Range(""C"" & n & "":D"" & n).Merge"
'.InsertLines x + 12, "Me.Range(""E"" & n) = """""
'.InsertLines x + 13, " Me.Range(""F"" & n) = Cells(21, 5)"
'.InsertLines x + 14, " Me.Range(""F"" & n & "":G"" & n).Merge"
'.InsertLines x + 15, " Else"
'.InsertLines x + 16, " For i = 28 To n"
'.InsertLines x + 17, " If Me.Range(""C"" & i) = st Then"
'.InsertLines x + 18, " Me.Range(""A"" & i + 1).Offset(-1, 0).EntireRow.Delete"
'.InsertLines x + 19, " End If"
'.InsertLines x + 20, " Next"
'.InsertLines x + 21, "End If"
'.InsertLines x + 22, " End With"
'.InsertLines x + 23, "End Sub"
'End With
'Next i
'End Sub
Function FindAll(ByVal rng As Range, ByVal searchTxt As String) As Range
    Dim foundCell As Range
    Dim firstAddress
    Dim rResult As Range
    With rng
        Set foundCell = .Find(What:=searchTxt, _
                              After:=.Cells(.Cells.Count), _
                              LookIn:=xlValues, _
                              LookAt:=xlWhole, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlNext, _
                              MatchCase:=False)
        If Not foundCell Is Nothing Then
            firstAddress = foundCell.Address
            Do
                If rResult Is Nothing Then
                    Set rResult = foundCell
                Else
                    Set rResult = Union(rResult, foundCell)
                End If
                Set foundCell = .FindNext(foundCell)
            Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
        End If
    End With

    Set FindAll = rResult
End Function

Sub copy_elem()
Dim rng1, rng2, rng3 As Range, addr$, adr$
Dim wt1, wt2 As Worksheet
Dim str As String
Set wt1 = Worksheets("Input Form")
Set wt2 = Worksheets("RPT_ELEM_REL")
str = wt1.Range("A27").Value
With wt2.Range("B:B")
Set rng1 = .Find(str, LookAt:=1)
addr = rng1.Address
Do
Set rng1 = .FindNext(rng1)
adr = rng1.Address
'ToggleButton1.Value = True
'ToggleButton1.Value = False
Set rng2 = wt1.Range("A31")
Set rng3 = rng1.EntireRow.Range("a1:m1")
rng3.Copy
rng2.Insert Shift:=xlDown
Loop Until addr = rng1.Address
End With
End Sub

Sub copy_tab(str As String, tname As String, rowf As String, n As Integer)
Dim rng1, rng2, rng3 As Range, addr$, adr$
Dim wt1, wt2 As Worksheet
Set wt1 = Worksheets("Input Form")
Set wt2 = Worksheets(tname)
With wt2.Range(rowf)
Set rng1 = .Find(str, LookAt:=1)
addr = rng1.Address
If rng1.row <> 0 And rng1.Value <> "" Then
Do
Set rng1 = .FindNext(rng1)
adr = rng1.Address
Set rng2 = wt1.Range("A" & n)
Set rng3 = rng1.EntireRow.Range("a1:m1")
rng3.Copy
rng2.Insert Shift:=xlDown
Loop Until addr = rng1.Address
End If
End With
End Sub

Sub DelRange(str As String)
Dim n As Integer
Dim m As Integer
Dim rng As Range
Dim wt As Worksheet
Set wt = Worksheets("Input Form")
Call Findblankrange(str, n, m)
If m + 2 = n Then
'MsgBox "No need to delete."
Else
wt.Range("A" & m + 2 & ":M" & n - 1).EntireRow.Delete
End If
End Sub

Sub DelRecords(tname As String, str As String, rown As String)
Dim rng1 As Range
', addr$, adr$
'Dim n As Integer
Dim wt1 As Worksheet
'On Error Resume Next
Set wt1 = Worksheets(tname)
With wt1.Range(rown)
Set rng1 = .Find(str, LookAt:=1)
If Not rng1 Is Nothing Then
'addr = rng1.Address
Do
'n = rng1.row
'MsgBox n
rng1.EntireRow.Delete
Set rng1 = .FindNext()  'findnex can no parameter
Loop While Not rng1 Is Nothing 'And addr <> rng1.Address
End If
End With
End Sub

Sub copy_range(tname As String, n As Integer, m As Integer)
Dim rng1, rng2, rng3 As Range
Dim end_row As Integer
Dim wt1, wt2 As Worksheet
Set wt1 = Worksheets("Input Form")
Set wt2 = Worksheets(tname)
end_row = wt2.UsedRange.Rows.Count + 1
'MsgBox m + 2 & "||" & n - 1
With wt1
Set rng1 = .Range("A" & m + 2 & ":M" & n - 1)
'end_row = wt2.Range("A" & end_row).End(xlDown).row + 1
'MsgBox end_row
Set rng2 = wt2.Range("A" & end_row)
rng1.Copy
rng2.PasteSpecial (xlPasteValues)
Application.CutCopyMode = xlCut
End With
End Sub

以上是module 部分

 

以下是功能键

Private Sub CheckBox1_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox1
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox10_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox10
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox11_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox11
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox12_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox12
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox13_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox13
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox14_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox14
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox15_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox15
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox16_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox16
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox17_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox17
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox18_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox18
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox19_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox19
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox2_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox2
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox20_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox20
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox21_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox21
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox22_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox22
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox23_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox23
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox24_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox24
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox25_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox25
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox26_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox26
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox27_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox27
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox28_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox28
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox29_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox29
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox3_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox3
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox30_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox30
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox31_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox31
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox32_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox32
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox33_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox33
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox34_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox34
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox35_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox35
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox36_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox36
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox37_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox37
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox38_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox38
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox39_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox39
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox4_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox4
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox40_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox40
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox41_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox41
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox42_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox42
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox43_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox43
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox44_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox44
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox45_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox45
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox46_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox46
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox47_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox47
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox48_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox48
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox49_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox49
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox5_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox5
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox50_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox50
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox51_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox51
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox52_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox52
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox53_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String ' the table name
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox53
st = .Caption
Call Findblankrange(tname, n, m)
'MsgBox m
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox54_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox54
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox55_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox55
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox56_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox56
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox57_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox57
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox58_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox58
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox59_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox59
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox6_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox6
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox60_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox60
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox61_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox61
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox62_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox62
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox63_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox63
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox64_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox64
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox65_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox65
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox66_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox66
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox67_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox67
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox68_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox68
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox69_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox69
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox7_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox7
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox70_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox70
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox71_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox71
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox72_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox72
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox73_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox73
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox74_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox74
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox75_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox75
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox76_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox76
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox77_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox77
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox78_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox78
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox79_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String ' the table name
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox79
st = .Caption
Call Findblankrange(tname, n, m)
'MsgBox m
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox8_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox8
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox80_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox80
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox81_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox81
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox82_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox82
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox83_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox83
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox84_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox84
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox85_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox85
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox86_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox86
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox87_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox87
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox88_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox88
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox89_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox89
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox9_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox9
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

Private Sub CheckBox90_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_FF_REPORTS_REL"
With Me.CheckBox90
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline2(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox91_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox91
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox92_Click()
Dim n As Integer
Dim m As Integer
Dim tname As String
Dim st As String
Application.ScreenUpdating = False
tname = "REFER_CTRY_REPORTS_REL"
With Me.CheckBox92
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline1(st, n)
Else
Call Delline(st, n, m)
End If
End With
Application.ScreenUpdating = True
End Sub

Private Sub CheckBox93_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox93
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub


Private Sub CheckBox94_Click()
Dim n As Integer ' first row number of the blank
Dim m As Integer ' start row number of the table
Dim tname As String ' the table name
Dim st As String  'button caption
tname = "RPT_ELEM_REL"
With Me.CheckBox94
st = .Caption
Call Findblankrange(tname, n, m)
If .Value Then
Call Addnewline(st, n)
Else
Call Delline(st, n, m)
End If
End With
End Sub

'This is the submit button.
Private Sub CommandButton1_Click()
'On Error Resume Next
Dim row_1 As Integer
row_1 = Sheets("REFER_REPORTS").UsedRange.Rows.Count + 1
Dim row_2 As Integer
row_2 = Sheets("RPT_ELEM_REL").UsedRange.Rows.Count + 1
Dim str_1 As String

Dim rn As Integer
 
rn = Worksheets("REFER_REPORTS").Range("A" & row_1 - 1).Value + 1
If rn < 20000 Then
rn = 20000
End If

Sheets("Input Form").Range("E2").Value = rn
Label1.Caption = rn
If vbOK = MsgBox("Confirm Submission", vbOKCancel, "prompt") Then
Application.ScreenUpdating = False
Dim st1 As String
Dim st2 As Range
Dim ft As Integer
st1 = Worksheets("Input Form").Range("E3").Value
Set st2 = Worksheets("REFER_REPORTS").Range("B2:B" & row_1)
If Application.WorksheetFunction.CountIf(st2, st1) = 0 Then

Call past

'Call past2
Dim tname2 As String
Dim er2 As Integer
Dim sr2 As Integer
tname2 = "RPT_ELEM_REL"
Call Findblankrange(tname2, er2, sr2)
Call copy_range(tname2, er2, sr2)

Call past3

Call past4

MsgBox "Submit completed."
Label1.Caption = Worksheets("REFER_REPORTS").Range("A" & row_1).Value + 1
Sheets("Input Form").Range("E2").Value = Label1.Caption
Worksheets("Input Form").Activate
'Call clearcheckbox
  Else
     MsgBox "RPT_ID Duplicate,Please Amend."
     Worksheets("Input Form").Activate
End If
Else
  MsgBox "Cancel Submission."
  Call clearcheckbox
Dim tname11 As String
Dim tname22 As String
Dim tname33 As String
tname11 = "RPT_ELEM_REL"
tname22 = "REFER_CTRY_REPORTS_REL"
tname33 = "REFER_CTRY_FF_REPORTS_REL"
Call DelRange(tname11)
Call DelRange(tname22)
Call DelRange(tname33)
End If
Application.ScreenUpdating = True
End Sub
'this is the query button
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Call clearcheckbox
Dim tname1 As String
Dim tname2 As String
Dim tname3 As String
tname1 = "RPT_ELEM_REL"
tname2 = "REFER_CTRY_REPORTS_REL"
tname3 = "REFER_CTRY_FF_REPORTS_REL"
Call DelRange(tname1)
Call DelRange(tname2)
Call DelRange(tname3)


    Dim rng1, rng2, rng3 As Range
    Dim n As Integer
    Dim str As String
    Dim wt1, wt2 As Worksheet
    Set wt1 = Worksheets("Input Form")
    Set wt2 = Worksheets("REFER_REPORTS")
    wt1.Range("A27:M27").ClearContents
    str = InputBox("Please input your RPT_ID.", "RPT_ID")
    On Error Resume Next
    'n = wt2.Range("B:B").Find(str, LookAt:=1).Row
    With wt2.Range("B:B")
    Set rng1 = .Find(str, LookAt:=1)
    Set rng2 = wt1.Range("A27")
    n = rng1.row
    If n = 0 Then
    MsgBox "Can't find your RPT_ID."
    ElseIf str = "" Then
    'MsgBox "User Cancel."
    Else
    wt1.Range("E3").Value = UCase(str)
    wt1.Range("E2").Value = rng2.Value
    
    Set rng3 = rng1.EntireRow.Range("a1:m1")
    rng3.Copy
    rng2.PasteSpecial (xlPasteValues) 'no need format only value
    Application.CutCopyMode = xlCut
    wt1.Range("E2").Value = wt1.Range("A27").Value 'set report number
    Label1.Value = True
    
    '''RPT_ELEM_REL
    Dim en1 As Integer
    Dim st1 As Integer
    Dim str1 As String
    Dim rowstr1 As String
    str1 = wt1.Range("A27").Value
    rowstr1 = "B:B"
    Call Findblankrange(tname1, en1, st1)
    Call copy_tab(str1, tname1, rowstr1, en1)
    'Call copy_elem  ' can be replaced by copy_tab
    
    'next copy REFER_CTRY_REPORTS_REL
    Dim en2 As Integer
    Dim st2 As Integer
    Dim str2 As String
    Dim rowstr2 As String
    str2 = wt1.Range("B27").Value
    rowstr2 = "E:E"
   ' Dim en, st As Integer
    Call Findblankrange(tname2, en2, st2)
    Call copy_tab(str2, tname2, rowstr2, en2)
    '''''copy REFER_CTRY_FF_REPORTS_REL
    Dim en3 As Integer
    Dim st3 As Integer
    'Dim str3 As String
    Dim rowstr3 As String
    'str3 = wt1.Range("B27").Value
    rowstr3 = "F:F"
   ' Dim en, st As Integer
    Call Findblankrange(tname3, en3, st3)
    Call copy_tab(str2, tname3, rowstr3, en3)
    End If
End With
 Application.ScreenUpdating = True

End Sub
'This is the modify button.
Private Sub CommandButton3_Click()
'1 query
'2 delete
'3 submit
Application.ScreenUpdating = False
Dim str As String
Dim str1 As String
Dim str2 As String
Dim str3 As String
Dim str4 As String
Dim row1 As String
Dim row2 As String
Dim row3 As String
Dim row4 As String
Dim tname As String
tname = "Input Form"
Dim tname1 As String
Dim tname2 As String
Dim tname3 As String
Dim tname4 As String
Dim wt1 As Worksheet
Set wt1 = Worksheets(tname)
tname1 = "REFER_REPORTS"
tname2 = "RPT_ELEM_REL"
tname3 = "REFER_CTRY_REPORTS_REL"
tname4 = "REFER_CTRY_FF_REPORTS_REL"
Dim er1 As Integer
Dim er2 As Integer
Dim er3 As Integer
Dim er4 As Integer
Dim sr1 As Integer
Dim sr2 As Integer
Dim sr3 As Integer
Dim sr4 As Integer
str1 = wt1.Range("E3").Value
str2 = wt1.Range("A27").Value
str = wt1.Range("B27").Value
str3 = str1
str4 = str1
row1 = "B:B"
row2 = "B:B"
row3 = "E:E"
row4 = "F:F"

MsgBox "Modify need to query first then delete the exist records ,finally submit the modified records."
'CommandButton2 = True
If str2 <> "" Then

If vbOK = MsgBox("Really want to delete these records?", vbOKCancel, "prompt") Then

'Call DelRecords(tname, str, row1)

Call DelRecords(tname1, str1, row1)

Call DelRecords(tname2, str2, row2)

Call DelRecords(tname3, str3, row3)

Call DelRecords(tname4, str4, row4)
MsgBox "Delete Completed."

If vbOK = MsgBox("Really want to Modify these records?", vbOKCancel, "prompt") Then


'REFER_REPORTS
Call past
'Call Findblankrange(tname1, er1, sr1)
'Call copy_range(tname1, er1, sr1)

'RPT_ELEM_REL
Call Findblankrange(tname2, er2, sr2)
Call copy_range(tname2, er2, sr2)

'REFER_CTRY_REPORTS_REL
Call Findblankrange(tname3, er3, sr3)
Call copy_range(tname3, er3, sr3)

'REFER_CTRY_FF_REPORTS_REL
Call Findblankrange(tname4, er4, sr4)
Call copy_range(tname4, er4, sr4)
MsgBox "Modify success."
Else
MsgBox "Cancel modify Success."
End If
Else
MsgBox "Cancel delete success."
End If
Else
MsgBox "Can't find the report id,please query first!"
End If
Application.ScreenUpdating = True
End Sub
'This is the delete button.
Private Sub CommandButton4_Click()
CommandButton2 = True 'first display all data
Dim str1 As String
Dim str2 As String
Dim str3 As String
Dim str4 As String
Dim row1 As String
Dim row2 As String
Dim row3 As String
Dim row4 As String
Dim tname1 As String
Dim tname2 As String
Dim tname3 As String
Dim tname4 As String
Dim wt1 As Worksheet
tname1 = "REFER_REPORTS"
tname2 = "RPT_ELEM_REL"
tname3 = "REFER_CTRY_REPORTS_REL"
tname4 = "REFER_CTRY_FF_REPORTS_REL"
Set wt1 = Worksheets("Input Form")
Application.ScreenUpdating = False
tname1 = "REFER_REPORTS"
str1 = wt1.Range("E3").Value
str2 = wt1.Range("A27").Value
str3 = str1
str4 = str1
row1 = "B:B"
row2 = "B:B"
row3 = "E:E"
row4 = "F:F"
If str2 <> "" Then
wt1.Range("E2").Value = str2
If vbOK = MsgBox("Really want to delete these records?", vbOKCancel, "prompt") Then
'MsgBox str2
'Worksheets(tname1).Active
Call DelRecords(tname1, str1, row1)
 'Worksheets(tname2).Active
'If str2 <> "" Then
Call DelRecords(tname2, str2, row2)
'End If
 'Worksheets(tname3).Active
Call DelRecords(tname3, str3, row3)
 'Worksheets(tname4).Active
Call DelRecords(tname4, str4, row4)
MsgBox "Delete Completed."
Else
MsgBox "Cancel Success."
End If
Else
MsgBox "Please click query first"
End If
 Application.ScreenUpdating = True
End Sub

Private Sub Label1_Click()
MsgBox ">_< Easter Egg!^_^!" & Me.OLEObjects.Count
Label1.Caption = Sheets("Input Form").Range("E2").Value
End Sub

Private Sub ToggleButton1_Click()
Application.ScreenUpdating = False
With ToggleButton1
If .Value = True Then
    .Caption = "All OFF"
Call Allon
Else
    .Caption = "All ON"
Call Alloff
End If
End With
Application.ScreenUpdating = True
End Sub

 

moscot_wu
关注
  • 1
    点赞
  • 踩
  • 0
    收藏
    觉得还不错? 一键收藏
  • 1
    评论
专栏目录
的模块名称功能_MyVBA加载宏——添加自定义菜单04——功能实现
weixin_40002238的博客
12-14 569
有了前面的功能分析基础，使用VBA代码实现这个功能就不是很难了，逐行读取CommandBarDir.txt里面的信息，然后创建弹出式菜单或者按钮，最终实现的效果如下：功能实现01类模块功能类模块CCommandBar就是为了响应单击按钮的功能：根据单击的按钮的名称，读取对应名称的txt文件将读取到的文本插入到VBE中所以，分别先实现2个函数，读取txt文件的内容在前面有过介绍：VBA调用...
Excel
greenhair的博客
03-11 546
今天学了Excel表格 1. 先安装应用库 pip install xlrd == 1.2.0 pip install xlwt #导入库 import xlrd #读取Excel文件 import xlwt #写入Excel文件 2. 读取文件 workbook=xlrd.open_workbook(’ ')#打开工作簙 获取Sheet： sheet_names：获取所有的sheet`的名字。 sheet_by_index：根据索引获取sheet对象。 sheet_by_name
Excel 按钮，多选框提交实例
moscot_wu的博客
05-13 878
用户有一个Excel，多个sheet，然后首页是一些下拉框和填充框，所有的数据在其他sheet页，客户非常苦恼每次需要在各页找到相关的内容，然或填写到首页，并且首页填写的内容可以自动填充到各个Sheet页。 方法：使用Excel的VB脚本实现，首页信息填充后，点击按钮实现提交的功能。脚本如下: Private Sub CheckBox1_Click() Dim n As Integer Di...
Range 对象应用（下）
好好学习，天天向上！
04-13 1205
本文整理了以前的一些关于Find方法的文章，作为Excel VBA应用大全的一部分。<br />1. Find方法的作用<br />使用VBA在工作表或单元格区域中查找某项数据时，我们通常使用For…Next循环，这在小范围中使用还可以，但应用在大量数据中查找时，会耗费较多时间。<br />而在Excel工作表中，通常使用菜单“编辑>>查找”命令或按Ctrl+F组合键，在“查找和替换”对话框中来迅速查找所需的数据。在VBA中，我们也能使用这种方法，即Find方法，这在下面的内容中介绍。<br />Find方
【一】Excel VBA开发 初探
oJuHao12345的专栏
05-26 3384
一、启用Excel VBA开发功能 1、点击Excel左上角的【文件】，然后点击文件下方的【选项】 2、【Excel选项】中点击【自定义功能区】，右边勾选【开发工具】，点击【确定】 3、返回excel sheet 页面。点击【开发工具】,我们将看到三个我们开发过程中必用的按钮，分别是：【Visual Basic】、【宏】、【录制宏】 二、启动VBA编辑 点击【Visual Basic】 三、代码学习 Office Visual Basic for Applic...
vba删除当前工作表中所有的空行
yy5560的博客
09-06 2102
excel表格处理当前工作表时，如果有几行中穿插着空白行，把下面代码复制进去，自动删除掉 Sub DeleteBlankRow() Dim IngFirstRow As Long Dim IngLastRow As Long Dim a As Integer IngFirstRow = ActiveSheet.UsedRange.Row IngLastRow = IngFirstRow + ActiveSheet.UsedRange.Rows.Count ...
Excel实战技巧精粹.rar
09-06
电子表格Excel实战技巧精粹，主要讲述以下几个功能：①Excel电子表格的基本功能；②Excel电子表格的数据分析；③电子表格中使用函数 基础；④使用函数技巧；⑤电子表格中函数高级应用；⑥图表与图形；⑦VBA二次开发...
中级excel实战训练-1
05-30
本“中级Excel实战训练-1”旨在深入讲解一系列实用技能，包括维度逆转、分列神技、定位专家、高级筛选以及有效性下拉框与二级有效性等。以下是对这些知识点的详细说明： 1. **维度逆转**： 维度逆转通常是指在处理...
excel实战精粹
04-09
excel实战精粹是excelhome精心编织的excel学习资料
Excel实战技巧1000例.rar
04-19
"Excel实战技巧1000例"这个压缩包资源，无疑为Excel的学习者提供了一个丰富的实践宝库。以下将围绕Excel的一些重要知识点进行详细阐述，帮助你深入理解并运用这些技巧。 1. **公式与函数**：Excel的核心功能之一...
Excel操作大全
11-28
Delphi动态调用Excel操作大全
网页版EXCEL
12-14
网页版EXCEL，目前只兼容IE
Excel实战技巧精粹：Excel模板1000例
07-02
《Excel实战技巧精粹：Excel模板1000例》是一部深入探讨Excel应用的宝典，旨在提升用户在日常工作中处理数据、分析信息和优化工作效率的能力。这本书包含了丰富的实例和实用模板，覆盖了从基础操作到高级技巧的全...
Excel实战 第1章 数据处理
weixin_46713695的博客
01-13 1134
数据处理
Excel自学三部曲_Part3：Excel工作场景实战（一）
最新发布
毛媛媛
09-01 709
Excel的高频场景和功能到底有哪些？
实战excel
feverfew1的博客
01-31 482
文本为Excel中的常见格式，自由地使用Excel进行数据分析、数据统计，解放Excel不再为Excel所困
VBA 操作 VBE
weixin_33713503的博客
09-06 954
Introduction You can write code in VBA that reads or modifies other VBA projects, modules, or procedures. This is called extensibility because extends the editor -- you can used VBA code to create ne...
20170719xlVbaAbsorbProcedure
weixin_30662849的博客
07-19 131
Sub AbsorbThisProcedure() If Application.VBE.MainWindow.Visible = False Then MsgBox "请先激活VBE编辑窗口再执行!" Exit Sub End If On Error Resume Next Set VbCodePane = ...
Excel实战
weixin_44549096的博客
01-08 503
Excel实战 1、表格设计，自动求和、求平均值函数 打印预览按钮 添加边框 1、选中区域 2、选择对应的模式 3、预览效果 添加背景（不会被打印出来，只供自己看着舒服） 1、选中任意一个单元格，选择 页面布局-背景 2、效果 3、选中清单，背景填充 白色 4、选中 第一列，插入两列 5、将靠近清单一列，填充白色，缩小列宽 6、清单右侧，同样操作 7、清单上侧，添加一行，设置背景颜色：无填充 8、取消表格中的边框 9、效果展示 求和函数和求平均
Excel 实战技巧：快速批量处理与自动保存
"Excel 实战技巧汇总，包括批量添加固定字符、设置文件下拉窗口的最近文件数量、处理自动识别的日期格式、启用自动保存功能、创建多页表格的重复标题以及一次性设置多个工作表的页眉页脚和打印设置。" 在Excel中...
评论 1
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值