Excel 实战

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