VBA講座 レッスン2 Findメソッド
入出庫・在庫表＆月別売上高
■本格的データベースプログラミング
■商品マスターを作成
商品マスターには商品コードと商品名・単価を入れます。
■商品マスターには商品の出荷合計と入荷数合計・在庫数が表示されます。
■売上シートでは月別の売上高が表示されます。
■入出荷シート
商品コードを入れると商品名が表示されます。
日付を入れて、入荷ならば入荷の列に数量を入れます。
商品が売れれば日付と出荷の欄に数量を入れます。
■年度別月別売上高が表示されます。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WS2 As Worksheet
Dim RowEnd As Long
Dim nRow As Long
Dim nCol As Long
nRow = Target.Row
nCol = Target.Column
If nCol = 1 Then Call Tikucoad(nRow, nCol)
If nCol = 1 And Cells(nRow, 7) = "" Then Exit Sub
If nCol > 6 Then Exit Sub
' If nCol > 2 Then Exit Sub
Call Nyuka_keisan
End Sub
Private Sub Tikucoad(nRow As Long, nCol As Long)
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = ActiveWorkbook.Worksheets(1)
Set WS2 = ActiveWorkbook.Worksheets(2)
hinban = WS2.Cells(nRow, nCol)
Set FoundCell = WS1.Columns("A").Find(hinban, lookat:=xlWhole)
If Not FoundCell Is Nothing Then
Application.EnableEvents = False
WS2.Cells(nRow, nCol + 1) = WS1.Cells(FoundCell.Row, 2)
WS2.Cells(nRow, nCol + 3) = WS1.Cells(FoundCell.Row, 3)
Application.EnableEvents = True
Exit Sub
End If
MsgBox ("見つかりません")
End Sub
Private Sub Nyuka_keisan()
'On Error Resume Next
Dim WB As Workbook
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim FoundCell As Range
Dim FirstCell As Range
Dim rowCount As Long
Dim rowNo As Long
Dim WS1End As Long
Set WB = ActiveWorkbook
Set WS1 = WB.Worksheets(1)
Set WS2 = WB.Worksheets(2)
'------出入荷データ再計算------------------
WS1End = WS1.Range("A1").CurrentRegion.Rows.Count
Application.EnableEvents = False
For nRow = 2 To WS1End
hinban = WS1.Cells(nRow, 1)
nyuka = 0: syuka = 0
Set FoundCell = WS2.Columns("A").Find(hinban, lookat:=xlWhole)
If Not FoundCell Is Nothing Then
rowCount = FoundCell.Row
nyuka = WS2.Cells(rowCount, 5)
syuka = WS2.Cells(rowCount, 6)
WS2.Cells(rowCount, 7) = WS2.Cells(rowCount, 4) * _
WS2.Cells(rowCount, 6)
rowNo = FoundCell.Row
Set FirstCell = FoundCell
Do
Set FoundCell = WS2.Columns("A").FindNext(FoundCell)
If Not FoundCell Is Nothing Then
rowCount = FoundCell.Row
If FoundCell.Row > rowNo Then
nyuka = nyuka + WS2.Cells(rowCount, 5)
syuka = syuka + WS2.Cells(rowCount, 6)
WS2.Cells(rowCount, 7) = WS2.Cells(rowCount, 4) _
* WS2.Cells(rowCount, 6)
End If
End If
Loop Until FoundCell.Address = FirstCell.Address
End If
'マスターに書き込み
WS1.Cells(nRow, 4) = nyuka
WS1.Cells(nRow, 5) = syuka
WS1.Cells(nRow, 6) = nyuka - syuka
Next nRow
Application.EnableEvents = True
Uriage
End Sub
Private Sub Uriage()
'On Error Resume Next
Dim WB As Workbook
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim rowCount As Long
Dim rowNo As Long
Dim WS1End As Long
Dim hiduke As Date
Set WB = ActiveWorkbook
Set WS1 = WB.Worksheets(2)
Set WS2 = WB.Worksheets(3)
'------売上計算------------------
wsEnd1 = WS1.Range("A1").CurrentRegion.Rows.Count 'yahoo
WS2.Cells.Clear
WS2.Range("A1") = "年度月別"
WS2.Range("B1") = "売上"
ReDim suN(wsEnd1 + 1, 2)
suN(0, 0) = wsEnd1
s0 = 1
For i = 2 To suN(0, 0)
hiduke = WS1.Cells(i, 3) '日付
suN(s0, 0) = hiduke
suN(s0, 1) = WS1.Cells(i, 7)
s0 = s0 + 1
Next i
'shell-metzner sort--------------------
n = suN(0, 0) 'ﾃﾞｰﾀ件数
510 d = 1
520 d = d + d: If d > n Then GoTo 580 Else GoTo 520
530 For i = 1 To n - d: j = i
540 k = j + d: If suN(k, 0) >= suN(j, 0) Then GoTo 570
550 X = suN(k, 0): suN(k, 0) = suN(j, 0): suN(j, 0) = X
X = suN(k, 1): suN(k, 1) = suN(j, 1): suN(j, 1) = X
560 j = j - d: If j > 0 Then GoTo 540
570 Next i
580 d = Int((d - 1) / 2): If d > 0 Then GoTo 530
'--------------------------------------
s = 2: kei = 0
For u = 2 To suN(0, 0)
dayM = Year(suN(u, 0)) & "/" & Month(suN(u, 0))
dayM1 = Year(suN(u + 1, 0)) & "/" & Month(suN(u + 1, 0))
kei0 = suN(u, 1)
kei = kei + kei0
If dayM <> dayM1 Then
WS2.Cells(s, 1) = dayM
WS2.Cells(s, 2) = kei
s = s + 1
kei = 0
End If
Next u
End Sub