| |
▼miyama さん：
Sheet2のシートモジュールにどうぞ
Private Const C_JOIN_STR As String = vbTab
Private Sub Worksheet_Change(ByVal Target As Range)
Const EventCellString As String = "S6"
Dim EventCell As Excel.Range
Set EventCell = Range(EventCellString)
If Not (Intersect(EventCell, Target) Is Nothing) Then
Call DispTotal(EventCell.Value)
End If
If Not (EventCell Is Nothing) Then Set EventCell = Nothing
End Sub
Private Sub DispTotal(ByVal SearchKey As String)
Const C_SHT_DATA As String = "Sheet1"
Const C_SHT_POST As String = "Sheet2"
Dim Ret As Boolean
Dim Msg As String
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Ret = AcquisitionData(C_SHT_DATA, SearchKey, Dic, Msg)
If (Ret) Then
Ret = PostData(C_SHT_POST, Dic, Msg)
If (Ret = False) Then Call MsgBox(Msg, vbCritical)
Else
Call MsgBox(Msg, vbCritical)
End If
If Not (Dic Is Nothing) Then Set Dic = Nothing
End Sub
Private Function PostData(ByVal SheetName As String, ByRef Dic As Object, ByRef Msg As String) As Boolean
Const C_COL_COMMODITY As String = "A"
Const C_COL_MODEL As String = "B"
Const C_COL_AMOUNT As String = "C"
Const C_ROW_TITLE As Long = 1
Const C_STR_COMMODITY As String = "商品"
Const C_STR_MODEL As String = "型式"
Const C_STR_AMOUNT As String = "個数"
Const C_MSG_ERR As String = "該当するデータがありません。"
Dim Ret As Boolean
Dim Row As Long
Dim Sht As Excel.Worksheet
Dim Val As Variant
Dim iii As Long
Application.EnableEvents = False
Set Sht = ThisWorkbook.Sheets(SheetName)
Row = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
'転記先クリア
Sht.Range(C_COL_COMMODITY & C_ROW_TITLE & ":" & C_COL_AMOUNT & Row).ClearContents
'表題セット
Sht.Range(C_COL_COMMODITY & C_ROW_TITLE).Value = C_STR_COMMODITY
Sht.Range(C_COL_MODEL & C_ROW_TITLE).Value = C_STR_MODEL
Sht.Range(C_COL_AMOUNT & C_ROW_TITLE).Value = C_STR_AMOUNT
If (1 <= Dic.Count) Then
Row = 1
For iii = 0 To Dic.Count - 1
Row = Row + 1
Val = Split(Dic.Keys()(iii), C_JOIN_STR)
Sht.Range(C_COL_COMMODITY & Row).Value = Val(0)
Sht.Range(C_COL_MODEL & Row).Value = Val(1)
Sht.Range(C_COL_AMOUNT & Row).Value = Dic.Items()(iii)
Next iii
Ret = True
Else
Msg = C_MSG_ERR
Ret = False
End If
Exit_Function:
Application.EnableEvents = True
PostData = Ret
Exit Function
Err_Function:
Ret = False
Msg = Err.Description
Err.Clear
Resume Exit_Function
End Function
Private Function AcquisitionData(ByVal SheetName As String, ByVal SearchKey As String, ByRef RetDic As Object, ByRef Msg As String) As Boolean
On Error GoTo Err_Function
Const C_ROW_START As Long = 2
Const C_COL_NAME As String = "B"
Const C_COL_COMMODITY As String = "C"
Const C_COL_MODEL As String = "D"
Const C_COL_AMOUNT As String = "E"
Const C_MSG_ERR As String = "この企業のデータはありません。"
Dim Ret As Boolean
Dim Sht As Excel.Worksheet
Dim Row As Long
Dim EndRow As Long
Dim PrimaryKey As String
Dim Commodity As String
Dim Model As String
Dim Amount As Double
Set Sht = ThisWorkbook.Sheets(SheetName)
EndRow = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
For Row = C_ROW_START To EndRow
If (Sht.Range(C_COL_NAME & Row).Value = SearchKey) Then
Amount = Sht.Range(C_COL_AMOUNT & Row).Value
If Not (Amount = 0) Then
Commodity = Sht.Range(C_COL_COMMODITY & Row).Value
Model = Sht.Range(C_COL_MODEL & Row).Value
PrimaryKey = Commodity & C_JOIN_STR & Model
RetDic(PrimaryKey) = RetDic(PrimaryKey) + Amount
End If
End If
Next Row
If RetDic.Count = 0 Then
Msg = C_MSG_ERR
Ret = False
Else
Ret = True
End If
Exit_Function:
If Not (Sht Is Nothing) Then Set Sht = Nothing
AcquisitionData = Ret
Exit Function
Err_Function:
Ret = False
Msg = Err.Description
Err.Clear
Resume Exit_Function
End Function
|
|
こたつねこ
- 10/12/18(土) 14:30 -
