Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


14609 / 76738 ←次へ | 前へ→

【67618】Re:1つの条件で表示
回答  こたつねこ  - 10/12/18(土) 14:30 -

引用なし
パスワード
   ▼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
0 hits

【67604】1つの条件で表示 miyama 10/12/17(金) 14:39 質問
【67606】Re:1つの条件で表示 Jaka 10/12/17(金) 15:19 発言
【67607】Re:1つの条件で表示 UO3 10/12/17(金) 15:47 回答
【67616】Re:1つの条件で表示 miyama 10/12/18(土) 11:41 発言
【67619】Re:1つの条件で表示 UO3 10/12/18(土) 15:52 回答
【67611】Re:1つの条件で表示 kanabun 10/12/18(土) 0:23 発言
【67617】Re:1つの条件で表示 miyama 10/12/18(土) 11:51 発言
【67618】Re:1つの条件で表示 こたつねこ 10/12/18(土) 14:30 回答
【67630】Re:1つの条件で表示 Hirofumi 10/12/19(日) 18:33 回答
【68005】Re:1つの条件で表示 miyama 11/1/25(火) 9:44 お礼

14609 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free