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