VBA_sample - [新]パソコン忘備録

Top > VBA_sample
VBA Sample

集計

   Sub 支社別集計()
       Dim Sheet1, Sheet2 As Worksheet
       Const COL店舗CD = 1 ' 店舗CDの列
       Const COL分類CD = 3 ' 分類CDの列
       Const COL売上額 = 10 ' 売上額
       Dim MaxRow As Long ' 最終行
       Dim key As String ' 検索キー
       Dim c, r As Long
       
       Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
       
       Set Sheet1 = Worksheets("売上明細") ' 明細シート
       Set Sheet2 = Worksheets("売上集計") ' 集計シート
       
       MaxRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row ' 最終行を求める
       
       ' 売上明細を連想配列へ読み込む
       With Sheet1
           For r = 2 To MaxRow ' 最終行
               key = .Cells(r, COL店舗CD) & .Cells(r, COL分類CD) ' 店舗CD & 分類CD
               dicT(key) = dicT(key) + .Cells(r, COL売上額) ' 売上額
           Next
       End With
           
       ' 集計シートへの書き出し
       With Sheet2
           For c = 3 To 12 ' 列
               For r = 4 To 12 ' 行
                   key = .Cells(2, c) & .Cells(r, 1) ' 店舗CD & 分類CD
                   .Cells(r, c) = dicT(key)
               Next
           Next
       End With
   End Sub

---

◆サジェスト検索

Sub 入力規則リスト(str As String, cSh As Worksheet)
    Dim buf As String, tmp As Variant
    Dim Sh As Worksheet
    Range("リスト").ClearContents
    buf = str
    tmp = Split(buf, ",")
    Set Sh = Worksheets("リスト用")
    Sh.Activate
    Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)) = WorksheetFunction.Transpose(tmp)
    Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)).Name = "リスト"
    cSh.Activate
End Sub
 
Sub 入力候補表示(Sh As String, Rg As String, Tg As Range)
 
    Dim foundCell As Variant
    Dim listSheet As String '辞書のシート名
    Dim strDictionary As String '辞書の範囲
    Dim matchKey As String
    Dim strFormula As String ' 入力規則に入れる文字列
    Dim firstAddress As String ' 最初の結果のアドレス
    Dim matchWord As String
    Dim roopCount As Long
    Dim lngY As Long, intX As Long
 
    If Tg.Count > 1 Then Exit Sub
 
    ' アクティブセルの値が辞書に載っているか検索
    listSheet = Sh ' 検索対象シート
 
    strDictionary = Rg  ' 検索対象範囲
 
 
 
    matchKey = Tg.Value
 
    '部分一致で検索する（完全一致での検索を回避）
    Set foundCell = Worksheets(listSheet).Range(strDictionary).Find(What:=matchKey, LookAt:=xlPart)
 
    ' 検索結果が空の場合終了
    If foundCell Is Nothing Then Exit Sub
 
    ' 検索結果を回す
 
    strFormula = ""
    roopCount = 0
    firstAddress = foundCell.Address
    Do
        ' 辞書から入力候補を収集
        lngY = foundCell.Cells.Row
        intX = foundCell.Cells.Column
        matchWord = Worksheets(listSheet).Cells(lngY, intX).Value
 
        '比較
        If InStr(matchWord, matchKey) > 0 Then
            strFormula = strFormula & matchWord & ","
        End If
 
        roopCount = roopCount + 1
 
        ' 次の入力候補へ
        Set foundCell = Worksheets(listSheet).Range(strDictionary).FindNext(foundCell)
 
 
    Loop While (Not foundCell Is Nothing) And (firstAddress <> foundCell.Address)
 
    ' 入力候補をセット
    Application.EnableEvents = False
 
 
    If roopCount = 1 Then
    '候補が一つの場合、それを入力
 
        If Tg = "" Then 'エラー処理
                Application.EnableEvents = True
                strFormula = ""
                Tg.Select
                Exit Sub
        Else
            Tg.Value = Left(strFormula, Len(strFormula) - 1)
        End If
 
    ElseIf Len(strFormula) > 0 Then
 
 
    'リストという名前の範囲を生成し配列を代入する
    Application.ScreenUpdating = False
    Call 入力規則リスト(strFormula, ActiveSheet)
    Application.ScreenUpdating = True
    '候補が複数ある場合は、候補のリストを表示
        On Error GoTo ErrorHandler
        With Tg.Validation '入力規則を設定
            .Delete
            .Add Type:=xlValidateList, Formula1:="=リスト"
            .ShowError = False
            .InCellDropdown = True
        End With
        Tg.Select
        SendKeys "%{DOWN}"
    End If
 
    Set foundCell = Nothing
    strFormula = ""
    Application.EnableEvents = True
 
ErrorHandler:
    Application.EnableEvents = True
    strFormula = ""
End Sub

Private Sub Worksheet_Change(ByVal target As Range)
 
    '辞書（住所の候補）を設定する：郵便番号データから候補表示
    'DicSheetNameは辞書のシート名、
    'DicRangeAddressは辞書の範囲を指定する
    '
    Const DicSheetName = "郵便番号データ"
    Const DicRangeAddress = "A:A"
 
     If target.Count > 1 Then
     '選択セルが２つ以上は無効
         Set target = Nothing
         Exit Sub
 
     ElseIf Application.Intersect(target, Range("A4")) Is Nothing Then
      '入力セル以外の変更では無効(targetと共有するセル範囲がない）
         Exit Sub
 
     Else
         '入力されたアドレスが住所入力のアドレスの場合に候補を表示
             Call 入力候補表示(DicSheetName, DicRangeAddress, target)
     End If
 
End Sub

---

samplebas
jyushoBas
bad