Excel VBA質問箱 IV

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

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


57248 / 76732 ←次へ | 前へ→

【24221】Re:集計
回答  Hirofumi  - 05/4/15(金) 22:01 -

引用なし
パスワード
   こんな様に成るのかな?

Option Explicit

Public Sub AddUp2()

  Dim i As Long
  Dim j As Long
  Dim lngFindCol As Long
  Dim lngFindRow As Long
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim dicColIndex As Object
  Dim dicRowIndex As Object
  Dim vntKey As Variant
  Dim vntCustomer As Variant
  Dim rngResult As Range
  Dim rngList As Range
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim strProm As String
  
  '得意先の一覧表を作成(Sheet2A列に書かれるグループ順に羅列)
  vntCustomer = Array("得意先A", "得意先B", "得意先C")
  
  'Dictionaryオブジェクトのインスタンスを取得(Sheet2A列のIndex用)
  Set dicRowIndex = CreateObject("Scripting.Dictionary")
  'Dictionaryオブジェクトのインスタンスを取得(Sheet1行の店Index用)
  Set dicColIndex = CreateObject("Scripting.Dictionary")
  
  'シートの表の先頭セルを設定
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  
  '店名のセル位置を取得
  With rngResult
    lngColumns = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    If lngColumns <= 0 Then
      strProm = "店名データが有りません"
      GoTo Wayout
    End If
    vntData = .Offset(, 1).Resize(, lngColumns).Value
  End With
  With dicColIndex
    For i = 1 To UBound(vntData, 2)
      If Not .Exists(vntData(1, i)) Then
        .Add vntData(1, i), i
      Else
        strProm = "店名が重複しています"
        GoTo Wayout
      End If
    Next i
  End With
  
  '項目区2のセル位置を取得
  With rngResult
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "項目2データが有りません"
      GoTo Wayout
    End If
    vntData = .Offset(1).Resize(lngRows).Value
  End With
  With dicRowIndex
    For i = 1 To UBound(vntData, 1)
      If vntData(i, 1) <> "" Then
        If j <= UBound(vntCustomer) Then
          vntKey = vntCustomer(j) & vbTab & vntData(i, 1)
          If Not .Exists(vntKey) Then
            .Add vntKey, i
          Else
            strProm = "?が重複しています"
            GoTo Wayout
          End If
        End If
      Else
        j = j + 1
      End If
    Next i
  End With
  
  '結果出力用配列を確保
  ReDim vntResult(1 To lngRows, 1 To lngColumns)
  
  'Sheet1の商品コードのセル位置を基準として設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  '"Sheet1"のデータ数を取得
  With rngList
    'データの行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'もし、データが有る場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With

  '表に転記
  For i = 1 To lngRows
    vntData = rngList.Offset(i).Resize(, 8).Value
    If vntData(1, 8) = "売上" Then
      '得意先&項目2の行位置を探索
      vntKey = vntData(1, 2) & vbTab & vntData(1, 3)
      With dicRowIndex
        If .Exists(vntKey) Then
          lngFindRow = .Item(vntKey)
        Else
          lngFindRow = 0
        End If
      End With
      '店名を探索
      With dicColIndex
        If .Exists(vntData(1, 7)) Then
          lngFindCol = .Item(vntData(1, 7))
        Else
          lngFindCol = 0
        End If
      End With
      If lngFindCol > 0 And lngFindRow > 0 Then
        '発見した行列に値を加算
        vntResult(lngFindRow, lngFindCol) _
            = vntResult(lngFindRow, lngFindCol) + vntData(1, 6)
      End If
    End If
  Next i
  
  Application.ScreenUpdating = False
  
  '結果を出力
  With rngResult.Offset(1, 1)
    .Resize(UBound(vntResult, 1), _
        UBound(vntResult, 2)).Value = vntResult
  End With
  
  Application.ScreenUpdating = True
    
  strProm = "処理が完了しました"
  
Wayout:
  
  'Dictionaryオブジェクトのインスタンスを破棄
  Set dicRowIndex = Nothing
  Set dicColIndex = Nothing
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

尚、前回のコードで以下が違っていたので修正

  '得意先と商品コード列を削除
'  rngListTop.Offset(, -2).EntireColumn.Delete '★変更
  rngListTop.Offset(, -2).Resize(, 2).EntireColumn.Delete
0 hits

【24170】集計 AZ 05/4/14(木) 11:11 質問
【24172】Re:集計 ぴかる 05/4/14(木) 11:37 発言
【24187】Re:集計 Hirofumi 05/4/14(木) 22:22 回答
【24189】Re:集計 AZ 05/4/14(木) 23:54 質問
【24221】Re:集計 Hirofumi 05/4/15(金) 22:01 回答
【24243】Re:集計 AZ 05/4/16(土) 20:15 質問
【24245】Re:集計 Hirofumi 05/4/16(土) 22:13 回答
【24247】Re:集計 AZ 05/4/16(土) 22:58 お礼

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