Excel VBA質問箱 IV

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

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


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

【23981】検索 転記 合計値 momomi 05/4/9(土) 0:25 質問[未読]
【23982】Re:検索 転記 合計値 ウッシ 05/4/9(土) 0:43 回答[未読]
【24018】Re:検索 転記 合計値 YN61 05/4/9(土) 23:52 発言[未読]
【24020】Re:検索 転記 合計値 YN61 05/4/10(日) 0:17 発言[未読]
【24023】Re:検索 転記 合計値 YN61 05/4/10(日) 0:35 回答[未読]
【24031】Re:検索 転記 合計値 momomi 05/4/10(日) 12:06 質問[未読]
【24033】Re:検索 転記 合計値 ウッシ 05/4/10(日) 13:41 回答[未読]
【24035】Re:検索 転記 合計値 YN61 05/4/10(日) 14:02 回答[未読]
【24037】Re:検索 転記 合計値 YN61 05/4/10(日) 16:29 発言[未読]
【24038】Re:検索 転記 合計値 YN61 05/4/10(日) 18:01 発言[未読]
【24040】Re:検索 転記 合計値 kobasan 05/4/10(日) 19:41 発言[未読]
【24044】Re:検索 転記 合計値 YN61 05/4/10(日) 23:18 質問[未読]
【24045】Re:検索 転記 合計値 kobasan 05/4/10(日) 23:37 回答[未読]
【24073】Re:検索 転記 合計値 YN61 05/4/11(月) 20:43 発言[未読]
【24078】Re:検索 転記 合計値 kobasan 05/4/11(月) 21:49 回答[未読]
【24053】Re:検索 転記 合計値 REI 05/4/11(月) 9:23 質問[未読]
【24072】Re:検索 転記 合計値 kobasan 05/4/11(月) 19:57 回答[未読]
【24081】Re:検索 転記 合計値 momomi 05/4/12(火) 8:16 お礼[未読]
【24042】Re:検索 転記 合計値 Hirofumi 05/4/10(日) 21:14 回答[未読]
【24043】Re:検索 転記 合計値 Hirofumi 05/4/10(日) 22:07 回答[未読]
【24082】Re:検索 転記 合計値 momomi 05/4/12(火) 8:17 お礼[未読]
【24127】Re:検索 転記 合計値 YN61 05/4/12(火) 18:13 発言[未読]

【23981】検索 転記 合計値
質問  momomi  - 05/4/9(土) 0:25 -

引用なし
パスワード
   こんばんは。初心者です

Sheet1にあるデータ(2000件)を検索し、Sheet2のように各品目ごとに並びかえ小計できるようにしたいのですが・・・VBAで動かしたいのです。
宜しくおねがいします。

<Sheet1>
  A     B     C    D   E    F  
 商品コード 品目   店コード  金額 消費税 合計 
1 1001   リンゴ   1   **** ****  ****
2 1002   ミカン    1    **** ****  ****
3 1001   リンゴ   2   **** ****  ****
4 1003   バナナ   1   **** ****  ****
5 1002   ミカン    2   **** ****  ****
6 1001   リンゴ   3   **** ****  ****
7 1003   バナナ   2   **** ****  ****
8 1001   リンゴ   4   **** ****  ****

<Sheet2>
 A     B     C     D   E    F  
 商品コード 品目  店コード   金額 消費税 合計 
1 1001   リンゴ   1   **** ****  ****
2 1001   リンゴ   2   **** ****  ****
3 1001   リンゴ   3   **** ****  ****
4 1001   リンゴ   4   **** ****  ****
5 リンゴ計           **** ****  ****    
6 1002   ミカン    1    **** ****  ****
7 1002   ミカン    2   **** ****  ****
8 ミカン計           **** ****  ****
9 1003   バナナ   1   **** ****  ****
10 1003   バナナ   2   **** ****  ****
11 バナナ計           **** ****  ****
12 合 計           **** ****  **** 

【23982】Re:検索 転記 合計値
回答  ウッシ  - 05/4/9(土) 0:43 -

引用なし
パスワード
   こんばんは

>Sheet1にあるデータ(2000件)を検索し
検索という意味が分らないです。

>商品コード 品目   店コード  金額 消費税 合計 
この項目は1行目に入ってないのですか?

入っていれば、
>Sheet1にあるデータ(2000件)を、Sheet2のように各品目ごとに並びかえ小計
これは、Sheet2全体をクリアして、Sheet1全体をコピーしてSheet2に貼り付けて
品目でソートして集計する処理をマクロに記録すればVBAコードが出来ますので
再利用可能ですよ。

【24018】Re:検索 転記 合計値
発言  YN61  - 05/4/9(土) 23:52 -

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

今晩は。テストしてみました。だけど小計が上手くまとまらないのですが…
このようなのでは、?
誰か、小計の仕方を訂正・追加してください。お願いします。

Sub 絞込みコピー()

  Dim myr As Range
  
  Sheets(1).Select
  Range("A1").Select
  Selection.AutoFilter
  Selection.AutoFilter Field:=2, Criteria1:=Range("H1").Value

  Selection.CurrentRegion.Offset(1).Select
  Selection.Copy
  
  Sheets(2).Select
  Cells(65536, 1).Offset(, 3).End(xlUp).Offset(1, -3).Select
  
  Selection.PasteSpecial Paste:=xlValues
  
  Cells(65535, 4).End(xlUp).Offset(1) = Application.WorksheetFunction. _
  Sum(Selection.Cells("4"))
  
 
End Sub


>Sheet1にあるデータ(2000件)を検索し、Sheet2のように各品目ごとに並びかえ小計できるようにしたいのですが・・・VBAで動かしたいのです。
>宜しくおねがいします。
>
><Sheet1>
>  A     B     C    D   E    F  
> 商品コード 品目   店コード  金額 消費税 合計 
>1 1001   リンゴ   1   **** ****  ****
>2 1002   ミカン    1    **** ****  ****
>3 1001   リンゴ   2   **** ****  ****
>4 1003   バナナ   1   **** ****  ****
>5 1002   ミカン    2   **** ****  ****
>6 1001   リンゴ   3   **** ****  ****
>7 1003   バナナ   2   **** ****  ****
>8 1001   リンゴ   4   **** ****  ****
>
><Sheet2>
> A     B     C     D   E    F  
> 商品コード 品目  店コード   金額 消費税 合計 
>1 1001   リンゴ   1   **** ****  ****
>2 1001   リンゴ   2   **** ****  ****
>3 1001   リンゴ   3   **** ****  ****
>4 1001   リンゴ   4   **** ****  ****
>5 リンゴ計           **** ****  ****    
>6 1002   ミカン    1    **** ****  ****
>7 1002   ミカン    2   **** ****  ****
>8 ミカン計           **** ****  ****
>9 1003   バナナ   1   **** ****  ****
>10 1003   バナナ   2   **** ****  ****
>11 バナナ計           **** ****  ****
>12 合 計           **** ****  ****

【24020】Re:検索 転記 合計値
発言  YN61  - 05/4/10(日) 0:17 -

引用なし
パスワード
   >▼momomi さん:

失礼しました
H1のセルには「リンゴ、ミカン、バナナ」のどれかをいれて
マクロを動かした下さい。

H1のセルに…データ→入力規則→リストでドロップダウンリストを作られると
便利かと思います。

【24023】Re:検索 転記 合計値
回答  YN61  - 05/4/10(日) 0:35 -

引用なし
パスワード
   ▼momomi さん:
一番下のコードが間違っていました。
これで、できると思います。

Sub 絞込みコピー訂正()

  Dim myr As Range
  
  Sheets(1).Select
  Range("A1").Select
  Selection.AutoFilter
  Selection.AutoFilter Field:=2, Criteria1:=Range("H1").Value

  Selection.CurrentRegion.Offset(1).Select
  Selection.Copy
  
  Sheets(2).Select
  Cells(65536, 1).Offset(, 3).End(xlUp).Offset(1, -3).Select
  
  
  Selection.PasteSpecial Paste:=xlValues
  
  Cells(65535, 4).End(xlUp).Offset(1) = Application.WorksheetFunction. _
  Sum(Selection.Columns(4))
  
  
End Sub

【24031】Re:検索 転記 合計値
質問  momomi  - 05/4/10(日) 12:06 -

引用なし
パスワード
   ウッシさん
アドバイスありがとうございました。

YN61 さん
ありがとうございました。
とても参考になりました。
金額計は値がでるのですが消費税・合計値がでません・・教えてください。

あと質問なのですが、品目も五十数種類もありまして・・検索結果を("H1")にコピーしたいのですが・・教えてください。
一応検索コードはつくりました。
宜しくお願いします。

Sub 検索()

Dim 検索 As Range

Set 検索 = Cells.Find("リンゴ")
If Not 検索 Is Nothing Then
検索.Activate
End If

End Sub

【24033】Re:検索 転記 合計値
回答  ウッシ  - 05/4/10(日) 13:41 -

引用なし
パスワード
   こんにちは

【23982】のマクロに記録したコードをちょっと修正したものです。
検索結果とは合計値でいいのですよね?

Sub test()
  Dim s As String
  
  s = "リンゴ"
  
  Application.ScreenUpdating = False
  With Worksheets("Sheet2")
    .Range("A1").ClearOutline
    .Range("A:F").ClearContents
    Worksheets("Sheet1").Range("A1").CurrentRegion.Copy
    .Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=False
    .Range("A1").Sort _
      Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes
    .Range("A1").Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5, 6), _
      Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    .Range("A1").ClearOutline
    .Range("A1").CurrentRegion.Value = .Range("A1").CurrentRegion.Value
    .Range("B:B").Find(s & " 計", , xlFormulas, xlWhole) _
      .Offset(, 4).Copy .Range("H1")
  End With
  Application.ScreenUpdating = True
End Sub

【24035】Re:検索 転記 合計値
回答  YN61  - 05/4/10(日) 14:02 -

引用なし
パスワード
   ▼momomi さん:
補足しておきます。
シート1においてシート関数で仕上げておいては?如何でしょう。
消費税の欄ですが…   =IF(D2="","",D2*1.05)
合計の欄ですが…    =IF(E2="","",E2*F2)
この関数は貴方の表に合わせて作成してくださいね。

このように仕上げるとマクロがシンプル簡単になると思います。
一部変更しました。コピーして試してみて下さい。
これで動くと思います。

商品の選択は私の書いたのが一番シンプルと思いますが?如何でしょう。
商品の数の変化にも対応しやすいですし、探すのも時間がかからないと
思いますが…

Sub 絞込みコピー()
 
  Sheets(1).Select
  Range("A1").Select
  Selection.AutoFilter
  Selection.AutoFilter Field:=2, Criteria1:=Range("H1").Value

  Selection.CurrentRegion.Offset(1).Select
  Selection.Copy
  
  Sheets(2).Select
  Cells(65536, 1).Offset(, 3).End(xlUp).Offset(1, -3).Select
  
  Selection.PasteSpecial Paste:=xlValues
  
  Dim myRange As Range
  Dim 列 As Integer
  Dim 開始 As Integer
  Dim 終了 As Integer
  Dim endR As Integer

  開始 = 4
  終了 = 7
  
 For 列 = 開始 To 終了
  endR = Cells(65536, 列).End(xlUp).Row
  Set myRange = Range(Cells(1, 列), Cells(endR, 列))
   Cells(endR + 1, 列) = Application.WorksheetFunction.Sum(myRange)
 Next 列
  Range("A1").Select
 
  Sheets(1).Select
  Range("A1").Select
  Selection.AutoFilter
  
End Sub

【24037】Re:検索 転記 合計値
発言  YN61  - 05/4/10(日) 16:29 -

引用なし
パスワード
   ▼momomi さん:
YNです。
若干ミスがありました。
再度コードを書きました。ご参考までに

Sub test3()

 
  Sheets(1).Select
  Range("A1").Select
  Selection.AutoFilter
  Selection.AutoFilter Field:=2, Criteria1:=Range("H1").Value

  Selection.CurrentRegion.Offset(1).Select
  Selection.Copy
  
  Sheets(2).Select
  Cells(65536, 1).Offset(, 3).End(xlUp).Offset(1, -3).Select
  
  Selection.PasteSpecial Paste:=xlValues
  
  Dim myRange As Range
  Dim 列 As Integer
  Dim 開始 As Integer
  Dim 終了 As Integer
  Dim endR As Integer

  開始 = 4
  終了 = 7
  
 For 列 = 開始 To 終了
  endR = Cells(65536, 列).End(xlUp).Row
  Set myRange = Range(Cells(endR, 列), Cells(Selection.Row, 列))
   Cells(endR + 1, 列) = Application.WorksheetFunction.Sum(myRange)
  
 Next 列
  Range("A1").Select
 
  Sheets(1).Select
  Range("A1").Select
  Selection.AutoFilter
  
End Sub

【24038】Re:検索 転記 合計値
発言  YN61  - 05/4/10(日) 18:01 -

引用なし
パスワード
   ▼momomi さん:
さっきから頑張って見直しました。
これで、使ってみてください。検索の意味が分かりません?

このコードはJIに「ミカン、リンゴ、バナナ」と明示するようにしています。
K列ではCurrentRegionにかかりそうですので、少し移動しました。
J1のところに「データ→入力規則→リスト」で、ここに商品名を入れてください。
商品名と商品名の間にには「コンマ」半角で入れないと動きませんのでご注意
下さい。

Sub test()
  Application.ScreenUpdating = False
  Sheets(1).Select
   Range("A1").Select
  
   Selection.AutoFilter
   Selection.AutoFilter Field:=2, Criteria1:=Range("J1").Value

   Selection.CurrentRegion.Offset(1).Select
   Selection.Resize(Selection.Rows.Count - 1, Selection.Columns.Count).Select
  Selection.Copy
  
  Sheets(2).Select
   Cells(65536, 1).Offset(, 3).End(xlUp).Offset(1, -3).Select
   Selection.PasteSpecial Paste:=xlValues
  
   Dim myRange As Range
   Dim 列 As Integer
   Dim 開始 As Integer
   Dim 終了 As Integer
   Dim endR As Integer

   開始 = 4
   終了 = 7
  
  For 列 = 開始 To 終了
   endR = Cells(65536, 列).End(xlUp).Row
   Set myRange = Range(Cells(endR, 列), Cells(Selection.Row, 列))
  
   Cells(endR + 1, 列) = Application.WorksheetFunction.Sum(myRange)
  Next 列
 
  Cells(65536, 2).End(xlUp).Offset(1).Value = Sheets(1).Range("J1").Value & "合計"
 
  Range("A1").Select
 
  Sheets(1).Select
  Range("A1").Select
  Selection.AutoFilter
  Application.ScreenUpdating = True
  
End Sub

【24040】Re:検索 転記 合計値
発言  kobasan  - 05/4/10(日) 19:41 -

引用なし
パスワード
   YN61 さん、今晩は。横から失礼します。

YN61 さんのコードを参考に作ってみました。
品名の単一リストを先ずつくり、それから抽出しました。

Range("J1").Valueを参照しないようにしました。


Sub 絞込みコピー貼付()
Dim c As Range
Dim X() As Variant
  Application.ScreenUpdating = False
  Sheets(2).Cells().ClearContents
  '-----タイトル行をコピー・貼付
  With Sheets(1)
    .Range("A1", .Cells(1, 200).End(xlToLeft)).Copy
  End With
  Sheets(2).Cells(1, 1).PasteSpecial Paste:=xlValues
  '-----品名の無重複データ作成
  With Sheets(1)
    n = 0
    For Each c In Range("B2", Sheets(1).Cells(65535, 2).End(xlUp))
      If Application.CountIf(.Range("B2", c), c.Value) = 1 Then
        n = n + 1
        ReDim Preserve X(1 To n)
        X(n) = c.Value
      End If
    Next
  End With
  '-----抽出・コピー・貼付
  For i = 1 To UBound(X)
    '-----抽出・コピー
    Sheets(1).Select
    Range("A1").Select
    Selection.AutoFilter Field:=2, Criteria1:=X(i)
    Selection.CurrentRegion.Offset(1).Copy
    '-----貼付
    Sheets(2).Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
    '-----AutoFilterを解除
    Sheets(1).Select
    Range("A1").Select
    Selection.AutoFilter
    '-----小計を格納
    Sheets(2).Select
    With Sheets(2).Cells(65535, 1).End(xlUp)
      .Offset(1, 0) = Trim(X(i)) & "計"
      .Offset(1, 3) = Application.WorksheetFunction.Sum(Selection.Columns(4))
      .Offset(1, 4) = Application.WorksheetFunction.Sum(Selection.Columns(5))
      .Offset(1, 5) = Application.WorksheetFunction.Sum(Selection.Columns(6))
    End With
  Next
  '-----合計を格納
  Sheets(2).Select
  With Sheets(2).Cells(65535, 1).End(xlUp)
    .Offset(1, 0) = "合 計"
    .Offset(1, 3) = Application.WorksheetFunction.Sum(Sheets(1).Columns(4))
    .Offset(1, 4) = Application.WorksheetFunction.Sum(Sheets(1).Columns(5))
    .Offset(1, 5) = Application.WorksheetFunction.Sum(Sheets(1).Columns(6))
  End With
End Sub

【24042】Re:検索 転記 合計値
回答  Hirofumi  - 05/4/10(日) 21:14 -

引用なし
パスワード
   取り越し苦労ならゴメン
もし、Sheet1のデータが商品コード別の店番別での集計も要るなら
こんな、形かな?

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub AddUp()

  'データの列数
  Const clngColumns As Long = 6
  
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim lngRows As Long
  Dim vntData As Variant
  Dim vntResult() As Variant
  Dim rngList As Range
  Dim strProm As String
  Dim lngWrite As Long
  Dim vntSubTotal As Variant
  Dim vntTotal() As Variant
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim vntItem As Variant
  
  'Listの左上隅を基準とする
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows < 1 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  'Dictionaryのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '商品コード別の店番別の集計
  With dicIndex
    'データの1行目から全ての行に就いて繰り返し
    For i = 1 To lngRows
      '行データを配列に取得
      vntData = rngList.Offset(i).Resize(, clngColumns).Value
      'Keyを作成
      vntKey = vntData(1, 1) & vbTab & vntData(1, 3)
      '商品コード別の店番別で金額、消費税、合計を集計
      If .Exists(vntKey) Then
        '集計用配列の格納位置を取得
        vntItem = .Item(vntKey)
        '集計用配列に集計
        For k = 4 To clngColumns
          vntResult(k, vntItem) _
              = vntResult(k, vntItem) + vntData(1, k)
        Next k
      Else
        '集計用配列の添え字の最大値をインクリメント
        j = j + 1
        '集計用配列を拡張
        ReDim Preserve vntResult(1 To clngColumns, 1 To j)
        For k = 1 To clngColumns
          vntResult(k, j) = vntData(1, k)
        Next k
        'dicIndexに登録
        .Add vntKey, j
      End If
    Next i
  End With
  
  'Dictionaryのインスタンスを破棄
  Set dicIndex = Nothing
  
  Application.ScreenUpdating = False
  
  'Sheet2に出力
  'Listの左上隅を基準とする
  Set rngList = Worksheets("Sheet2").Cells(1, "A")
  With rngList
    '項目を出力
    .Resize(, clngColumns).Value _
        = Array("商品コード", "品目", "店コード", "金額", "消費税", "合計")
    lngRows = UBound(vntResult, 2)
    With .Offset(1).Resize(lngRows, clngColumns)
      'データを出力
      .Value = Application.Transpose(vntResult)
      Erase vntResult
      'データの整列
      .Sort Key1:=.Item(1, 1), Order1:=xlAscending, _
          Key2:=Range("C2"), Order2:=xlAscending, _
          Header:=xlNo, OrderCustom:=1, _
          MatchCase:=False, Orientation:=xlTopToBottom, _
          SortMethod:=xlStroke
    End With
  End With
  
  '小計、計を集計
  '行挿入位置の初期値
  lngWrite = 2
  '総計出力用配列を確保
  ReDim vntTotal(1 To clngColumns)
  vntTotal(1) = "合計"
  '小計出力用配列を確保
  ReDim vntSubTotal(1 To clngColumns)
  With rngList
    '変数の初期値設定
    vntData = .Offset(1).Resize(, clngColumns).Value
    vntSubTotal(1) = vntData(1, 2)
    For j = 4 To clngColumns
      vntSubTotal(j) = vntData(1, j)
    Next j
    'データの2行目から全ての行に就いて繰り返し
    For i = 2 To lngRows
      '行データを配列に取得
      vntData = .Offset(lngWrite).Resize(, clngColumns).Value
      '小計を取っている商品コードと現在の商品コードが同じなら
      If vntSubTotal(1) = vntData(1, 2) Then
        '小計を加算
        For j = 4 To clngColumns
          vntSubTotal(j) = vntSubTotal(j) + vntData(1, j)
        Next j
      Else
        '小計を出力、総計にデータ追加
        DataWrite rngList, lngWrite, vntSubTotal, vntTotal
        '小計配列の初期値化
        vntSubTotal(1) = vntData(1, 2)
        For j = 4 To clngColumns
          vntSubTotal(j) = vntData(1, j)
        Next j
      End If
      '行挿入位置をインクリメント
      lngWrite = lngWrite + 1
    Next i
  End With
  '小計を出力、総計にデータ追加
  DataWrite rngList, lngWrite, vntSubTotal, vntTotal
  
  '総計出力用配列を出力
  rngList.Offset(lngWrite).Resize(, clngColumns).Value = vntTotal
  
  Application.ScreenUpdating = True
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Set rngList = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

Private Sub DataWrite(rngTop As Range, lngRow As Long, _
          vntSubTotal As Variant, vntTotal As Variant)

  '挿入行数
'  Const lngInsert As Long = 2
  Const lngInsert As Long = 1

  Dim i As Long
  
  '小計用配列を整える
  vntSubTotal(1) = CStr(vntSubTotal(1)) & "計"
  With rngTop
    '小計用配列を代入する行を挿入
    .Offset(lngRow).Resize(lngInsert).EntireRow.Insert
    '小計用配列を出力
    .Offset(lngRow).Resize(, UBound(vntSubTotal)).Value = vntSubTotal
  End With
  '行挿入位置をインクリメント
  lngRow = lngRow + lngInsert
  
  '総計用配列にデータ追加
  For i = 4 To UBound(vntTotal)
    vntTotal(i) = vntTotal(i) + vntSubTotal(i)
  Next i
  
End Sub

【24043】Re:検索 転記 合計値
回答  Hirofumi  - 05/4/10(日) 22:07 -

引用なし
パスワード
   前よりこっちの方が善いな

Option Explicit

Public Sub AddUp2()

  'データの列数
  Const clngColumns As Long = 6
  
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim lngRows As Long
  Dim vntData As Variant
  Dim vntResult() As Variant
  Dim rngList As Range
  Dim strProm As String
  Dim lngWrite As Long
  Dim vntSubTotal As Variant
  Dim vntTotal() As Variant
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim vntItem As Variant
  Dim vntHeader As Variant
  
  'Listの左上隅を基準とする
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows < 1 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '項目名を取得
    vntHeader = .Resize(, clngColumns).Value
  End With
  
  'Dictionaryのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '商品コード別の店番別の集計
  With dicIndex
    'データの1行目から全ての行に就いて繰り返し
    For i = 1 To lngRows
      '行データを配列に取得
      vntData = rngList.Offset(i).Resize(, clngColumns).Value
      'Keyを作成
      vntKey = vntData(1, 1) & vbTab & vntData(1, 3)
      '商品コード別の店番別で金額、消費税、合計を集計
      If .Exists(vntKey) Then
        '集計用配列の格納位置を取得
        vntItem = .Item(vntKey)
        '集計用配列に集計
        For k = 4 To clngColumns
          vntResult(k, vntItem) _
              = vntResult(k, vntItem) + vntData(1, k)
        Next k
      Else
        '集計用配列の添え字の最大値をインクリメント
        j = j + 1
        '集計用配列を拡張
        ReDim Preserve vntResult(1 To clngColumns, 1 To j)
        For k = 1 To clngColumns
          vntResult(k, j) = vntData(1, k)
        Next k
        'dicIndexに登録
        .Add vntKey, j
      End If
    Next i
  End With
  
  'Dictionaryのインスタンスを破棄
  Set dicIndex = Nothing
  
  Application.ScreenUpdating = False
  
  'Sheet2に出力
  'Listの左上隅を基準とする
  Set rngList = Worksheets("Sheet2").Cells(1, "A")
  With rngList
    '項目を出力
    .Resize(, clngColumns).Value = vntHeader
    lngRows = UBound(vntResult, 2)
    With .Offset(1).Resize(lngRows, clngColumns)
      'データを出力
      .Value = Application.Transpose(vntResult)
      Erase vntResult
      'データの整列
      .Sort Key1:=.Item(1, 1), Order1:=xlAscending, _
          Key2:=Range("C2"), Order2:=xlAscending, _
          Header:=xlNo, OrderCustom:=1, _
          MatchCase:=False, Orientation:=xlTopToBottom, _
          SortMethod:=xlStroke
    End With
  End With
  
  '小計、計を集計
  '行挿入位置の初期値
  lngWrite = 2
  '総計出力用配列を確保
  ReDim vntTotal(1 To clngColumns)
  vntTotal(1) = "合計"
  '小計出力用配列を確保
  ReDim vntSubTotal(1 To clngColumns)
  With rngList
    '変数の初期値設定
    vntData = .Offset(1).Resize(, clngColumns).Value
    vntSubTotal(1) = vntData(1, 1)
    vntSubTotal(2) = vntData(1, 2)
    For j = 4 To clngColumns
      vntSubTotal(j) = vntData(1, j)
    Next j
    'データの2行目から全ての行に就いて繰り返し
    For i = 2 To lngRows
      '行データを配列に取得
      vntData = .Offset(lngWrite).Resize(, clngColumns).Value
      '小計を取っている商品コードと現在の商品コードが同じなら
      If vntSubTotal(1) = vntData(1, 1) Then
        '小計を加算
        For j = 4 To clngColumns
          vntSubTotal(j) = vntSubTotal(j) + vntData(1, j)
        Next j
      Else
        '小計を出力、総計にデータ追加
        DataWrite rngList, lngWrite, vntSubTotal, vntTotal
        '小計配列の初期値化
        vntSubTotal(1) = vntData(1, 1)
        vntSubTotal(2) = vntData(1, 2)
        For j = 4 To clngColumns
          vntSubTotal(j) = vntData(1, j)
        Next j
      End If
      '行挿入位置をインクリメント
      lngWrite = lngWrite + 1
    Next i
  End With
  '小計を出力、総計にデータ追加
  DataWrite rngList, lngWrite, vntSubTotal, vntTotal
  
  '総計出力用配列を出力
  rngList.Offset(lngWrite).Resize(, clngColumns).Value = vntTotal
  
  Application.ScreenUpdating = True
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Set rngList = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

Private Sub DataWrite(rngTop As Range, lngRow As Long, _
          vntSubTotal As Variant, vntTotal As Variant)

  '挿入行数
'  Const lngInsert As Long = 2
  Const lngInsert As Long = 1

  Dim i As Long
  
  '小計用配列を整える
  vntSubTotal(1) = CStr(vntSubTotal(2)) & "計"
  vntSubTotal(2) = Empty
  With rngTop
    '小計用配列を代入する行を挿入
    .Offset(lngRow).Resize(lngInsert).EntireRow.Insert
    '小計用配列を出力
    .Offset(lngRow).Resize(, UBound(vntSubTotal)).Value = vntSubTotal
  End With
  '行挿入位置をインクリメント
  lngRow = lngRow + lngInsert
  
  '総計用配列にデータ追加
  For i = 4 To UBound(vntTotal)
    vntTotal(i) = vntTotal(i) + vntSubTotal(i)
  Next i
  
End Sub

【24044】Re:検索 転記 合計値
質問  YN61  - 05/4/10(日) 23:18 -

引用なし
パスワード
   ▼kobasan さん:
今晩は。

>Range("J1").Valueを参照しないようにしました。

kobasanの作成された方が、質問者の希望に合っているかも知れませんね。
よく分かりました。合計もできてよいですね。
私もじっくりと勉強させていただきたいと思います。
商品の検出・格納はどこでしているのでしょうか?


>Sub 絞込みコピー貼付()
>Dim c As Range
>Dim X() As Variant
>  Application.ScreenUpdating = False
>  Sheets(2).Cells().ClearContents
>  '-----タイトル行をコピー・貼付
>  With Sheets(1)
>    .Range("A1", .Cells(1, 200).End(xlToLeft)).Copy
>  End With
>  Sheets(2).Cells(1, 1).PasteSpecial Paste:=xlValues
>  '-----品名の無重複データ作成
>  With Sheets(1)
>    n = 0
>    For Each c In Range("B2", Sheets(1).Cells(65535, 2).End(xlUp))
>      If Application.CountIf(.Range("B2", c), c.Value) = 1 Then
>        n = n + 1
>        ReDim Preserve X(1 To n)
>        X(n) = c.Value
>      End If
>    Next
>  End With
>  '-----抽出・コピー・貼付
>  For i = 1 To UBound(X)
>    '-----抽出・コピー
>    Sheets(1).Select
>    Range("A1").Select
>    Selection.AutoFilter Field:=2, Criteria1:=X(i)
>    Selection.CurrentRegion.Offset(1).Copy
>    '-----貼付
>    Sheets(2).Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
>    '-----AutoFilterを解除
>    Sheets(1).Select
>    Range("A1").Select
>    Selection.AutoFilter
>    '-----小計を格納
>    Sheets(2).Select
>    With Sheets(2).Cells(65535, 1).End(xlUp)
>      .Offset(1, 0) = Trim(X(i)) & "計"
>      .Offset(1, 3) = Application.WorksheetFunction.Sum(Selection.Columns(4))
>      .Offset(1, 4) = Application.WorksheetFunction.Sum(Selection.Columns(5))
>      .Offset(1, 5) = Application.WorksheetFunction.Sum(Selection.Columns(6))
>    End With
>  Next
>  '-----合計を格納
>  Sheets(2).Select
>  With Sheets(2).Cells(65535, 1).End(xlUp)
>    .Offset(1, 0) = "合 計"
>    .Offset(1, 3) = Application.WorksheetFunction.Sum(Sheets(1).Columns(4))
>    .Offset(1, 4) = Application.WorksheetFunction.Sum(Sheets(1).Columns(5))
>    .Offset(1, 5) = Application.WorksheetFunction.Sum(Sheets(1).Columns(6))
>  End With
>End Sub

【24045】Re:検索 転記 合計値
回答  kobasan  - 05/4/10(日) 23:37 -

引用なし
パスワード
   ▼YN61 さん 今晩は。

>商品の検出・格納はどこでしているのでしょうか?

質問の意味が、よく理解できていないのですが。

>>  '-----品名の無重複データ作成
>>  With Sheets(1)
>>    n = 0
>>    For Each c In Range("B2", Sheets(1).Cells(65535, 2).End(xlUp))
>>      If Application.CountIf(.Range("B2", c), c.Value) = 1 Then
>>        n = n + 1
>>        ReDim Preserve X(1 To n)
>>        X(n) = c.Value
>>      End If
>>    Next
>>  End With

この部分かな?
質問からずれているかな?

【24053】Re:検索 転記 合計値
質問  REI  - 05/4/11(月) 9:23 -

引用なし
パスワード
   ▼kobasan さん
こんにちは
よこから失礼します。

同じ要領でC列の店コードの小計・合計はどのようにすればよいのでしょうか?(修正すれば)
お願いします。
>
>
>Sub 絞込みコピー貼付()
>Dim c As Range
>Dim X() As Variant
>  Application.ScreenUpdating = False
>  Sheets(2).Cells().ClearContents
>  '-----タイトル行をコピー・貼付
>  With Sheets(1)
>    .Range("A1", .Cells(1, 200).End(xlToLeft)).Copy
>  End With
>  Sheets(2).Cells(1, 1).PasteSpecial Paste:=xlValues
>  '-----品名の無重複データ作成
>  With Sheets(1)
>    n = 0
>    For Each c In Range("B2", Sheets(1).Cells(65535, 2).End(xlUp))
>      If Application.CountIf(.Range("B2", c), c.Value) = 1 Then
>        n = n + 1
>        ReDim Preserve X(1 To n)
>        X(n) = c.Value
>      End If
>    Next
>  End With
>  '-----抽出・コピー・貼付
>  For i = 1 To UBound(X)
>    '-----抽出・コピー
>    Sheets(1).Select
>    Range("A1").Select
>    Selection.AutoFilter Field:=2, Criteria1:=X(i)
>    Selection.CurrentRegion.Offset(1).Copy
>    '-----貼付
>    Sheets(2).Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
>    '-----AutoFilterを解除
>    Sheets(1).Select
>    Range("A1").Select
>    Selection.AutoFilter
>    '-----小計を格納
>    Sheets(2).Select
>    With Sheets(2).Cells(65535, 1).End(xlUp)
>      .Offset(1, 0) = Trim(X(i)) & "計"
>      .Offset(1, 3) = Application.WorksheetFunction.Sum(Selection.Columns(4))
>      .Offset(1, 4) = Application.WorksheetFunction.Sum(Selection.Columns(5))
>      .Offset(1, 5) = Application.WorksheetFunction.Sum(Selection.Columns(6))
>    End With
>  Next
>  '-----合計を格納
>  Sheets(2).Select
>  With Sheets(2).Cells(65535, 1).End(xlUp)
>    .Offset(1, 0) = "合 計"
>    .Offset(1, 3) = Application.WorksheetFunction.Sum(Sheets(1).Columns(4))
>    .Offset(1, 4) = Application.WorksheetFunction.Sum(Sheets(1).Columns(5))
>    .Offset(1, 5) = Application.WorksheetFunction.Sum(Sheets(1).Columns(6))
>  End With
>End Sub

【24072】Re:検索 転記 合計値
回答  kobasan  - 05/4/11(月) 19:57 -

引用なし
パスワード
   ▼REI さん今晩は。

「'<<<変更」が付いている行のみの変更できます。
試してみてください。


Sub 店コード絞込みコピー貼付()
Dim c As Range
Dim X() As Variant
  Application.ScreenUpdating = False
  Sheets(2).Cells().ClearContents
  '-----タイトル行をコピー・貼付
  With Sheets(1)
    .Range("A1", .Cells(1, 200).End(xlToLeft)).Copy
  End With
  Sheets(2).Cells(1, 1).PasteSpecial Paste:=xlValues
  '-----店コードの無重複データ作成
  With Sheets(1)
    n = 0
    For Each c In Range("C2", Sheets(1).Cells(65535, 3).End(xlUp)) '<<<変更
      If Application.CountIf(.Range("C2", c), c.Value) = 1 Then  '<<<変更
        n = n + 1
        ReDim Preserve X(1 To n)
        X(n) = c.Value
      End If
    Next
  End With
  '-----抽出・コピー・貼付
  For i = 1 To UBound(X)
    '-----抽出・コピー
    Sheets(1).Select
    Range("A1").Select
    Selection.AutoFilter Field:=3, Criteria1:=X(i) '<<<変更
    Selection.CurrentRegion.Offset(1).Copy
    '-----貼付
    Sheets(2).Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
    '-----AutoFilterを解除
    Sheets(1).Select
    Range("A1").Select
    Selection.AutoFilter
    '-----小計を格納
    Sheets(2).Select
    With Sheets(2).Cells(65535, 1).End(xlUp)
      .Offset(1, 0) = "店コード " & Trim(X(i)) & "の計" '<<<変更
      .Offset(1, 3) = Application.WorksheetFunction.Sum(Selection.Columns(4))
      .Offset(1, 4) = Application.WorksheetFunction.Sum(Selection.Columns(5))
      .Offset(1, 5) = Application.WorksheetFunction.Sum(Selection.Columns(6))
    End With
  Next
  '-----合計を格納
  Sheets(2).Select
  With Sheets(2).Cells(65535, 1).End(xlUp)
    .Offset(1, 0) = "合 計"
    .Offset(1, 3) = Application.WorksheetFunction.Sum(Sheets(1).Columns(4))
    .Offset(1, 4) = Application.WorksheetFunction.Sum(Sheets(1).Columns(5))
    .Offset(1, 5) = Application.WorksheetFunction.Sum(Sheets(1).Columns(6))
  End With
End Sub

【24073】Re:検索 転記 合計値
発言  YN61  - 05/4/11(月) 20:43 -

引用なし
パスワード
   ▼kobasan さん:
それからmomomiさん:今晩は

momomiさんのテーマで色々と発展した質問が出ていて驚いています。
momomiさん
結果から判断するとkobasanさんのコードが一番使い易そうですね。
完成度が抜群と思いますが。でも小生のように61歳の手習いには、一寸難しくって
理解できないところがありますが。

また、小生は勘違いをしていました。一挙に集計するのではなく、商品別に
集計するのだと思っていました。失礼しました。
でも。momomiさんが最初書かれているように2000件のデータで50商品の分類ですと
むしろ商品別に検出するマクロもいるのでは?っと思ったり…しましたが。

kobasanありがとうございました。勉強にはなりましたが、小生には少し難しいです。
肝心の部分だけでもコメントいただければありがたいのですが…

以下の部分です。

>  '-----品名の無重複データ作成
>  With Sheets(1)
>    n = 0
>    For Each c In Range("B2", Sheets(1).Cells(65535, 2).End(xlUp))
>      If Application.CountIf(.Range("B2", c), c.Value) = 1 Then
>        n = n + 1
>        ReDim Preserve X(1 To n)  >>ここが特に理解できません。
>        X(n) = c.Value    >>ここが特に理解できません
>      End If
>    Next
>  End With
>

今後ともよろしくお願いします。

【24078】Re:検索 転記 合計値
回答  kobasan  - 05/4/11(月) 21:49 -

引用なし
パスワード
   ▼YN61 さん今晩は。kobasanです。

わたしは、VBA についてまだまだ勉強中です。
YN61 さんのコードは分かりやすく、自分の勉強の材料になると思って、今回作ってみただけです。むしろ、YN61 さんのコードから色々なことを勉強させてもらいました。

>肝心の部分だけでもコメントいただければありがたいのですが…

VBE のヘルプで ReDim を検索してみてください。
ReDim Preserve について次のような説明があります。

ReDim [Preserve] varname(subscripts) [As type] [, varname(subscripts) [As type]] . . .

ReDim ステートメントの構文は、次の指定項目から構成されます。

指定項目 内容
Preserve 省略可能です。既存の配列に格納されている値を失うことなく、
配列の最後の次元の要素数を変更する場合に使用する、キーワードです。

>
>>  '-----品名の無重複データ作成
>>  With Sheets(1)
>>    n = 0
>>    For Each c In Range("B2", Sheets(1).Cells(65535, 2).End(xlUp))
>>      If Application.CountIf(.Range("B2", c), c.Value) = 1 Then
>>        n = n + 1
>>        ReDim Preserve X(1 To n)  >>ここが特に理解できません。
         '↑
         '配列の要素数を自由にに設定するためのものです
         '配列に格納されている値を失うことなく、
         '配列の最後に要素を追加します
>>        X(n) = c.Value    >>ここが特に理解できません
         '↑
         'CountIf が1なら品目がダブっていないので、
         '抽出のキーワードとして配列に格納します。
         '
>>      End If
>>    Next
>>  End With
>>

 Find や like を使った検索にこだわることなく、
要は検索したいキーワードを最初に全て調べて配列Xに格納し、
そのキーワードについて抽出を繰り返せばよいと考えただけです。

そのために、「品名の無重複データ作成」のブロックを作っただけです。

こんな説明で分かってもらえますでしょうか。

【24081】Re:検索 転記 合計値
お礼  momomi  - 05/4/12(火) 8:16 -

引用なし
パスワード
   おはようございます。
お礼が遅くなりすみませんでした。
早速、試したいとおもいます。(´ー`)♪

また何かありましたら宜しくお願い致します。

【24082】Re:検索 転記 合計値
お礼  momomi  - 05/4/12(火) 8:17 -

引用なし
パスワード
   おはようございます。
お礼が遅くなりすみませんでした。
早速、試したいとおもいます(´ー`)♪

また何かありましたら宜しくお願い致します。

【24127】Re:検索 転記 合計値
発言  YN61  - 05/4/12(火) 18:13 -

引用なし
パスワード
   ▼momomi さん:
こんにちは

そしてkobasanさん(色々とありがとうございました)
こんにちは…

会社で。ひおひねりしてきました。
シート3に集計しています。

一度これも試して見てください。できるだけシンプルにしようとしました。

Sub 検索転記小計合計()

 Sheets(3).Select
   Range("B2").Select
   Selection.RemoveSubtotal
   Columns("A:G").Select
   Selection.ClearContents
   Range("A1").Select
 Sheets(1).Select
   Range("A1").Select
   Selection.CurrentRegion.Select
   Selection.Copy
 Sheets(3).Select
   Range("A1").Select
   ActiveSheet.Paste
   Range("B2").Select

   Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
     OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
     :=xlPinYin
   Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6, 7), _
    Replace:=True, PageBreaks:=False, SummaryBelowData:=True
   Range("A1").Select
   Selection.CurrentRegion.Select
     With Selection.Borders '(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    End With
   Range("A1").Select
' Sheets(1).Select
'   Range("A1").Select
End Sub

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