Excel VBA質問箱 IV

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

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


10016 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【24170】集計
質問  AZ  - 05/4/14(木) 11:11 -

引用なし
パスワード
   いつも参考にさせていただいております。

下記のような感じで売上集計処理ができるようにしたいのですが・・
各得意先に振り分けが可能でしょうか?

<sheet1>
 A    B    C    D  E   F   G  H  
1 商品コード項目1    項目2    金額 消費税 合計    店 処理
2 1001    得意先A    リンゴ    ***  **  ***     1 売上
3 1002    得意先A    ミカン    ***  **      ***     2 売上
4 1003    得意先A    バナナ    ***  **      ***     1 売上
5 2010    得意先B    リンゴ    ***  **      ***     3 売上
6 3020    得意先C    リンゴ    ***  **      ***     4 売上
7 1002    得意先A    ミカン    ***  **      ***     2 売上
8 2011    得意先B    ミカン    ***  **      ***     3 売上
9 3021    得意先C    ミカン    ***  **      ***     2 売上

<sheet2>
  A  B  C  D   E  F  G  H
1    1  2  3  4  5  6  7 ←店名             
2リンゴ
3ミカン  ←得意先A
4バナナ

7リンゴ
8ミカン  ←得意先B
9バナナ

10リンゴ
11ミカン  ←得意先C
12バナナ


 

【24172】Re:集計
発言  ぴかる  - 05/4/14(木) 11:37 -

引用なし
パスワード
   AZさん、こんにちは。

一般機能のデータ→ピボットテーブルを使ってみてはどうですか?
データ集計には、めちゃ便利な機能です。ちと慣れが必要となりますが・・・。

【24187】Re:集計
回答  Hirofumi  - 05/4/14(木) 22:22 -

引用なし
パスワード
   上手く行かなかったらゴメン

Option Explicit

Public Sub AddUp()

  Dim i As Long
  Dim lngFindCol As Long
  Dim lngFindRow As Long
  Dim vntData As Variant
  Dim lngOver As Long
  Dim lngColNum As Long
  Dim lngRowNum As Long
  Dim rngScopeCol As Range
  Dim rngScopeRow As Range
  Dim rngListTop As Range
  Dim rngColItem As Range
  Dim rngRowItem As Range
  Dim lngRows As Long
  Dim strProm As String
  
  '"Sheet1"のデータを配列に取得
  With Worksheets("Sheet1").Cells(1, "A")
    'データの行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'もし、データが有る場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    vntData = .Offset(1).Resize(lngRows, 8).Value
  End With

  Application.ScreenUpdating = False
  
  '表を作るシートの表の先頭セル(後から2列削除に成るので、2列左の位置)
  Set rngListTop = Worksheets("Sheet2").Cells(1, "C")
  '列項目の初期値
  Set rngColItem = rngListTop.Offset(, 1)
  lngColNum = 0
  '行項目の初期値
  Set rngRowItem = rngListTop.Offset(1, -1)
  lngRowNum = 0
  
  '表に転記
  With rngListTop
    For i = 1 To UBound(vntData, 1)
      If vntData(i, 8) = "売上" Then
        '商品コードの行位置を探索
        lngFindRow = ItemSearch(vntData(i, 1), _
                  rngScopeRow, lngOver, 1)
        '探索値が無かった場合(未発見)
        If lngFindRow = 0 Then
          '探索範囲行数を更新
          lngRowNum = lngRowNum + 1
          '挿入位置に列を挿入
          With .Offset(lngOver)
            .EntireRow.Insert
          End With
          '挿入位置を発見位置に設定
          lngFindRow = lngOver
          '行項目の初期値を再設定
          Set rngRowItem = .Offset(1, -1)
          '挿入位置に商品コードを記入
          .Offset(lngFindRow, -1).Value = vntData(i, 1)
          .Offset(lngFindRow, -2).Value = vntData(i, 2)
          .Offset(lngFindRow, 0).Value = vntData(i, 3)
          '商品コードの探索範囲の取得
          Set rngScopeRow = rngRowItem.Resize(lngRowNum)
        End If
        '店名を探索
        lngFindCol = ItemSearch(vntData(i, 7), _
                    rngScopeCol, lngOver, 1)
        '店名が無かった場合(未発見)
        If lngFindCol = 0 Then
          '探索範囲列数を更新
          lngColNum = lngColNum + 1
          '挿入位置に列を挿入
          With .Offset(, lngOver)
            .EntireColumn.Insert
          End With
          '挿入位置を発見位置に設定
          lngFindCol = lngOver
          '列項目の初期値を再設定
          Set rngColItem = .Offset(, 1)
          With .Offset(, lngFindCol)
            'コード番号を記入
            .Value = vntData(i, 7)
          End With
          '店名の範囲を設定
          Set rngScopeCol = rngColItem.Resize(, lngColNum)
        End If
        '発見した行列に値を記入
        .Offset(lngFindRow, lngFindCol).Value _
            = .Offset(lngFindRow, lngFindCol).Value + vntData(i, 6)
      End If
    Next i
  End With
  
  '得意先別に1行空ける
  With rngRowItem
    vntData = .Offset(, -1).Resize(lngRowNum).Value
    For i = UBound(vntData, 1) - 1 To 1 Step -1
      If vntData(i + 1, 1) <> vntData(i, 1) Then
        .Offset(i).EntireRow.Insert
      End If
    Next i
  End With
  '得意先と商品コード列を削除
  rngListTop.Offset(, -2).EntireColumn.Delete
    
  strProm = "処理が完了しました"
  
Wayout:
  
  Set rngScopeCol = Nothing
  Set rngScopeRow = Nothing
  Set rngListTop = Nothing
  Set rngColItem = Nothing
  Set rngRowItem = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox strProm
  
End Sub

Private Function ItemSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngCollation As Long = 1) As Long

  Dim vntFind As Variant
  Dim lngDataTop As Long
  
  If rngScope Is Nothing Then
    lngOver = 1
    Exit Function
  End If
  
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngCollation)
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope.Cells(vntFind).Value Then
      '戻り値として、位置を代入
      ItemSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  Else
    lngOver = 1
  End If
  
End Function

【24189】Re:集計
質問  AZ  - 05/4/14(木) 23:54 -

引用なし
パスワード
   ▼Hirofumi さん

こんばんわ。ご指導ありがとうございました。
Sheet2の列・行見出しは記入されている感じでSheet1の処理が
表に転記されるような感じが理想なのですが・・
教えていただけますでしょうか?
お願いします。

【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

【24243】Re:集計
質問  AZ  - 05/4/16(土) 20:15 -

引用なし
パスワード
   ▼Hirofumi さん:
こんばんわ。

ありがとうございました。
とても参考になりました、もう一度質問させてください。
Sheet2の店名が数字ではなく文字(北海道、青森、他8県分あります)
だった場合、どの様にしたらよいでしょうか?教えてください。

【24245】Re:集計
回答  Hirofumi  - 05/4/16(土) 22:13 -

引用なし
パスワード
   ▼AZ さん:
>▼Hirofumi さん:
>こんばんわ。
>
>ありがとうございました。
>とても参考になりました、もう一度質問させてください。
>Sheet2の店名が数字ではなく文字(北海道、青森、他8県分あります)
>だった場合、どの様にしたらよいでしょうか?教えてください。

このままで、試して見ましたか?
一応、数値、文字列を意識し無い様に作った積もりですが?

【24247】Re:集計
お礼  AZ  - 05/4/16(土) 22:58 -

引用なし
パスワード
   ▼Hirofumi さん

勘違いでしたこの度は本当にありがとうございました。

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