入出庫データ連動在庫一覧表 （VBA Findメソッドプログラミング）

商品マスターに商品の入荷数と出荷数・在庫数が記録できるExcelシートです。
入出荷シートに商品の出入りを書き込むとマスターシートに自動的に在庫が表示できるシートです。
空いている列には色々とカスタマイズ出来ますので、十分に実用的です。
たとえば売上や、仕入れなども計算で出すことも可能です。
入出荷シートでコードを入力すると商品名が自動的に表示されます。

このプログラムはFindメソッドとWorksheet_Changeを使った実用的なプログラムです。
入出荷シートエディータに書き込みます。

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 = 4 Or nCol = 5 Then 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)
        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
   
    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, 4)
            syuka = WS2.Cells(rowCount, 5)
           
            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, 4)
                        syuka = syuka + WS2.Cells(rowCount, 5)
                    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
                                        
End Sub

但しこのプログラムでは不十分です。
マスターに同じ品番が登録されないようにする必要があります。
以下のプログラムはマスターに書き込みます。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nRow As Long
Dim nCol As Long
    nRow = Target.Row
    nCol = Target.Column
   
    If nCol <> 1 Then Exit Sub
    If Target = "" Then Exit Sub
   
    hinban = Cells(nRow, nCol)
                   
    Set FoundCell = Columns("A").Find(hinban, lookat:=xlWhole)
           
    If Not FoundCell Is Nothing Then
        If FoundCell.Row < nRow Then
            MsgBox ("同じ品番があります")
       
            Application.EnableEvents = False
            Cells(nRow, nCol) = ""
            Application.EnableEvents = True
        End If
  
    End If
     
End Sub

--------------------------------------------

このプログラムでもまだ不十分です。
マスターの品名を変更した場合、出入荷シートの品名は変更されません。
変更できるようにマスターのプログラムを変更します。
又、範囲を選択して削除した場合、エラーとなりますのでエラー対策をしておきましょう。

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim nRow As Long
Dim nCol As Long


    nRow = Target.Row
    nCol = Target.Column
    
    If nCol = 2 Then Call Hinmei_Change(nRow) 'この一行を追加します。
    If nCol <> 1 Then Exit Sub
    If Target = "" Then Exit Sub
    
    hinban = Cells(nRow, nCol)                   
    Set FoundCell = Columns("A").Find(hinban, lookat:=xlWhole)
            
    If Not FoundCell Is Nothing Then
        If FoundCell.Row < nRow Then
            MsgBox ("同じ品番があります")
        
            Application.EnableEvents = False
            Cells(nRow, nCol) = ""
            Application.EnableEvents = True
        End If
   
    End If       
End Sub




Private Sub Hinmei_Change(nRow As Long)
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
    
    Set WB = ActiveWorkbook
    Set WS1 = WB.Worksheets(1)
    Set WS2 = WB.Worksheets(2)
    
    hinban = WS1.Cells(nRow, 1)
    Hinmei = WS1.Cells(nRow, 2)
    
    Set FoundCell = WS2.Columns("A").Find(hinban, lookat:=xlWhole)
            
    If Not FoundCell Is Nothing Then
        Application.EnableEvents = False    
        rowCount = FoundCell.Row
        WS2.Cells(rowCount, 2) = Hinmei
        
        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
                    WS2.Cells(rowCount, 2) = Hinmei
                End If
               
            End If
    
        Loop Until FoundCell.Address = FirstCell.Address                  
        Application.EnableEvents = True
    End If
                                                 
End Sub