Lesson 1 1 EXVBA2000 Lesson01 Lesson01.xls 2

Size: px

Start display at page:

Download "Lesson 1 1 EXVBA2000 Lesson01 Lesson01.xls 2"

ほだかいとえ
9 years ago
Views:

1 Excel2000VBA L e a r n i n g S c h o o l 1

2 Lesson 1 1 EXVBA2000 Lesson01 Lesson01.xls 2

3 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

Range("B1") = Date CopyRows = GetRows(2) + 1 If CopyRows = 0 Then MsgBox " " Exit Sub End If StartRow

4 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

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.

5 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

Clear End Select Next 3 Module1:(General)-GetRows Public Function GetRows(ByVal SheetNo As Integer) As Long

6 1 6

7 2 7

8 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

9 Set WS = Worksheets(1) WS.Range("B1") = Date?date 00/01/17 9

10 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

11 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

12 8.Delete CopyRows = CopyRows + 1 Loop While DiffDate < 0 12

13 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

14 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

ColorIndex = 2 End With Case 0 With WS.Cells(StartRow, 3).Value = " " For i = 0 To 200.Interior.

15 10 15

16 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

Integer ByVal ByRef As Long Function End Function Function End Function 11

17 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

18 FAIL: MsgBox Error(Err.Number) End Function MaxRows = GetRows(1) For StartRow = 3 To MaxRows FAIL: GetRows = -1 End Function 13 18

19 Q1 19

コンピュータ概論

コンピュータ概論 5.1 VBA VBA Check Point 1. 2. 5.1.1 ( bug : ) (debug) On Error On Error On Error GoTo line < line > 5.1.1 < line > Cells(i, j) i, j 5.1.1 MsgBox Err.Description Err1: GoTo 0 74 Visual Basic VBA VBA Project