Excel VBA質問箱 IV

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

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


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

【19264】検索値を合計したい riririri 04/10/26(火) 23:17 質問[未読]
【19329】Re:検索値を合計したい Jaka 04/10/28(木) 13:13 発言[未読]
【19430】Re:検索値を合計したい riririri 04/11/1(月) 21:55 発言[未読]
【19432】Re:検索値を合計したい Asaki 04/11/2(火) 12:01 発言[未読]
【19433】Re:検索値を合計したい Jaka 04/11/2(火) 12:17 回答[未読]
【19440】Re:検索値を合計したい Hirofumi 04/11/3(水) 10:49 回答[未読]

【19264】検索値を合計したい
質問  riririri  - 04/10/26(火) 23:17 -

引用なし
パスワード
   シート1のA列に 日付(2004/08/21等)
B列に商品名 A・B・C・・・
c列にそれぞれの合計個数が集計されています。

シート2の
C5〜日付(8/21〜)の見出し
B7以下に商品名A・B・Cと入っている見出しの表の
交差する所にそれぞれの個数を入力されるように数式を
いれたいのですが いくら考えてもできません
ご指導どなたか下さい

(8/21のAの商品は 10こ 8/22は3個というように
日にちと商品ごとの集計です)

【19329】Re:検索値を合計したい
発言  Jaka  - 04/10/28(木) 13:13 -

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

なかなかレスがつかないようですが....。
よく解りません。
シートレイアウトなども記載して説明された方がいいと思います。

【19430】Re:検索値を合計したい
発言  riririri  - 04/11/1(月) 21:55 -

引用なし
パスワード
   詳細を明記します

シート2

     8/21 8/22 8/23 8/24 8/25〜
りんご
みかん
なし

シート1

8/21 りんご 3こ
8/21 みかん 2個
8/22 なし  1こ
8/22 りんご 5個

このようになっています、シート1の個数を、シート2の欄に自動で
個数を入力させたいのです。
たとえば8/21は なしは0(ゼロ)という風です。
お願い致します。

【19432】Re:検索値を合計したい
発言  Asaki  - 04/11/2(火) 12:01 -

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

ピボットテーブルではダメなのでしょうか?

【19433】Re:検索値を合計したい
回答  Jaka  - 04/11/2(火) 12:17 -

引用なし
パスワード
   こんにちは。
できたら結果も書いておいてください。
意味不明なときは、結果を判断材料にしたりするので....。

例えば

8/21 りんご 3こ
8/21 みかん 2個
8/22 なし  1こ
8/22 りんご 5個

の、3こ、2個などが表示形式で設定してあり、ただの数字が入っていれば普通の関数で出来そうですけど。

Sheet2のB1に

=SUMPRODUCT((Sheet1!$A$1:$A$4=Sheet2!B$1)*
(Sheet1!$B$1:$B$4=Sheet2!$A2),Sheet1!$C$1:$C$4)

を入れ、必要な所までフィルドラッグ。
これでもできますよ。
同じ日付で、同じ物が2つ以上あると加算しちゃうますけど。
また、適当な所で改行してありますから、直しても良いです。
(長いとUPできない。)

【19440】Re:検索値を合計したい
回答  Hirofumi  - 04/11/3(水) 10:49 -

引用なし
パスワード
   全てコードで行うとこんな?

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
  
  'デ−タの有るシートのデータを配列に取得
  'GetDataの第1引数:データを取得する配列
  '     第2引数:データの左上隅
  If GetData(vntData, Worksheets("Sheet1").Cells(1, "A")) = 0 Then
    Beep
    MsgBox "データが有りません"
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  
  '表を作るシートの先頭セルを設定
  Set rngListTop = Worksheets("Sheet2").Cells(1, "A")
  '表を作るシートをクリア
  rngListTop.Parent.Cells.Clear
  '列項目の初期値
  Set rngColItem = rngListTop.Offset(, 1)
  '行項目の初期値
  Set rngRowItem = rngListTop.Offset(1)
  
  '初期値設定
  With rngColItem
    '日付を記入
    'データに列見出しが無い場合
    '(有る場合は、vntData(2, 1))
    .Value = vntData(1, 1)
    '日付行の初期列設定
    lngColNum = 1
  End With
  With rngRowItem
    'Itemを記入
    'データに列見出しが無い場合
    '(有る場合は、vntData(2, 2))
    .Value = vntData(1, 2)
    'Item列の初期行設定
    lngRowNum = 1
  End With
  'データに列見出しが無い場合
  '(有る場合は、vntData(2, 3))
  rngListTop.Offset(lngRowNum, lngColNum).Value _
      = Val(StrConv(vntData(1, 3), vbNarrow))
  
  '表に転記
  With rngListTop
    'データに列見出しが無い場合
    '(有る場合は、i = 3から)
    For i = 2 To UBound(vntData, 1)
      'Itemの探索範囲の取得
      Set rngScopeRow = rngRowItem.Resize(lngRowNum)
      'Itemの行位置を探索
      lngFindRow = ItemSearch(vntData(i, 2), _
                rngScopeRow, lngOver, 0)
      '探索値が無かった場合(未発見)
      If lngFindRow = 0 Then
        '探索範囲行数を更新
        lngRowNum = lngRowNum + 1
        '最終行にItemを記入
        .Offset(lngRowNum).Value _
                = vntData(i, 2)
        '最終行の下を発見位置に設定
        lngFindRow = lngRowNum
      End If
      '日付の範囲を設定
      Set rngScopeCol = rngColItem.Resize(, lngColNum)
      '日付を探索
      lngFindCol = ItemSearch(CLng(vntData(i, 1)), _
                  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, 1)
        End With
      End If
      '発見した行列に値を記入
      .Offset(lngFindRow, lngFindCol).Value _
          = .Offset(lngFindRow, lngFindCol).Value _
              + Val(StrConv(vntData(i, 3), vbNarrow))
    Next i
  End With
  '日付を"m/d"形式に書式設定
  With rngScopeCol
    .Resize(, lngColNum).NumberFormatLocal = "m/d"
  End With
  
  Set rngScopeCol = Nothing
  Set rngScopeRow = Nothing
    
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Function GetData(vntData As Variant, _
            rngData As Range) As Long
  
  Dim rngScope As Range

  'データの左上隅を基準としてデータ範囲を取得
  Set rngScope = rngData.CurrentRegion
  With rngScope
    'rngScopeのデータを配列に取得
    vntData = .Value
    'データが無い場合
    If vntData(1, 1) = "" Then
      GetData = 0
    Else
      'データの最終行を取得
      GetData = .Rows.Count
    End If
  End With
  Set rngScope = Nothing

End Function

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

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