Excel2000VBA L e a r n i n g S c h o o l 1
Lesson 1 1 EXVBA2000 Lesson01 Lesson01.xls 2
3 Module1:(General)- Public Sub () Dim WS As Object Dim DiffDate As Integer Dim MaxRows As Integer, CopyRows As Integer Dim StartRow As Integer Dim i As Integer Set WS = Worksheets(1) WS.Range("B1") = Date CopyRows = GetRows(2) + 1 If CopyRows = 0 Then MsgBox " " Exit Sub End If StartRow = 3 Do If WS.Cells(StartRow, 1) = "" Then MsgBox " " Exit Sub End If DiffDate = WS.Cells(StartRow, 1) - WS.Range("B1") 3
If DiffDate < 0 Then With WS.Range(Cells(StartRow, 1), _ Cells(StartRow, 3)).Copy Destination:=Worksheets(2). _ Cells(CopyRows, 1).Delete End With CopyRows = CopyRows + 1 End If Loop While DiffDate < 0 MaxRows = GetRows(1) If MaxRows = -1 Then MsgBox " " Exit Sub End If For StartRow = 3 To MaxRows DiffDate = WS.Cells(StartRow, 1) - WS.Range("B1") Select Case DiffDate Case 3 With WS.Cells(StartRow, 3).Value = " " & DiffDate & " ".Interior.ColorIndex = 4 End With Case 2 With WS.Cells(StartRow, 3).Value = " " & DiffDate & " ".Interior.ColorIndex = 6 End With Case 1 With WS.Cells(StartRow, 3).Value = " ".Interior.ColorIndex = 7.Font.ColorIndex = 2 End With Case 0 With WS.Cells(StartRow, 3).Value = " " For i = 0 To 200.Interior.ColorIndex = 3 4
End Sub.Interior.ColorIndex = 1.Font.ColorIndex = 2 Next.Interior.ColorIndex = 3 End With Case Is >= 4 WS.Cells(StartRow, 3).Clear End Select Next 3 Module1:(General)-GetRows Public Function GetRows(ByVal SheetNo As Integer) As Long Dim i As Long Dim Result i = 2 On Error GoTo FAIL Set WS = Worksheets(SheetNo) Do i = i + 1 Result = WS.Cells(i, 1) Loop While Result <> "" GetRows = i - 1 Exit Function FAIL: '-1 GetRows = -1 End Function 5
1 6
2 7
3 Dim WS As Object Dim DiffDate As Integer Dim MaxRows As Integer, CopyRows As Integer Dim StartRow As Integer Dim i As Integer 4 8
Set WS = Worksheets(1) WS.Range("B1") = Date?date 00/01/17 9
5 CopyRows = GetRows(2) + 1 If CopyRows = 0 Then MsgBox " " Exit Sub End If 6 StartRow = 3 Do If WS.Cells(StartRow, 1) = "" Then MsgBox " " Exit Sub End If 10
DiffDate = WS.Cells(StartRow, 1) - WS.Range("B1") 7 If DiffDate < 0 Then With WS.Range(Cells(StartRow, 1), _ Cells(StartRow, 3)).Copy Destination:=Worksheets(2). _ Cells(CopyRows, 1) 11
8.Delete CopyRows = CopyRows + 1 Loop While DiffDate < 0 12
9 MaxRows = GetRows(1) If MaxRows = -1 Then MsgBox " " Exit Sub End If For StartRow = 3 To MaxRows DiffDate = WS.Cells(StartRow, 1) - WS.Range("B1") Select Case DiffDate Case 3 With WS.Cells(StartRow, 3).Value = " " & DiffDate & " ".Interior.ColorIndex = 4 End With 13
Case 2 With WS.Cells(StartRow, 3).Value = " " & DiffDate & " ".Interior.ColorIndex = 6 End With Case 1 With WS.Cells(StartRow, 3).Value = " ".Interior.ColorIndex = 7.Font.ColorIndex = 2 End With Case 0 With WS.Cells(StartRow, 3).Value = " " For i = 0 To 200.Interior.ColorIndex = 3.Interior.ColorIndex = 1.Font.ColorIndex = 2 Next.Interior.ColorIndex = 3 End With Case Is >= 4 WS.Cells(StartRow, 3).Clear 14
10 15
Public Function FuncName(ByVal Var As Integer) As Long End Function Public Function Public Private Function Function Sub FuncName Function ByVal Var As Integer ByVal ByRef As Long Function End Function Function End Function 11 Public Function GetRows(ByVal SheetNo As Integer) As Long Dim i As Long Dim Result i = 2 16
On Error GoTo FAIL Set WS = Worksheets(SheetNo) Do i = i + 1 Result = WS.Cells(i, 1) Loop While Result <> "" 12 GetRows = i - 1 Exit Function 17
FAIL: MsgBox Error(Err.Number) End Function MaxRows = GetRows(1) For StartRow = 3 To MaxRows FAIL: GetRows = -1 End Function 13 18
Q1 19