Excel VBA質問箱 IV

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

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


48469 / 76732 ←次へ | 前へ→

【33199】Re:シート1からシート2に対してグループ化集計
回答  Hirofumi  - 06/1/4(水) 20:55 -

引用なし
パスワード
   こうすれば善いと思います

Option Explicit

Public Sub Sample2()

  'データ列数
  Const clngColumns As Long = 30 '★変更
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim lngRow As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim strProm As String
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'データListの左上隅セル位置を基準として設定(列見出し「年月日」のセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  
  '出力Listの左上隅セル位置を基準として設定(列見出し「年月日」のセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  With rngResult
    'Sheet2をクリア
    .Parent.Cells.Clear
    '列見出しをSheet2にCopy
    rngList.Resize(, clngColumns).Copy _
              Destination:=.Item(1)
  End With
      
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  Set dicIndex = CreateObject("Scripting.Dictionary")

  With dicIndex
    lngRow = 1
    For i = 1 To lngRows
      'データを配列に取得
      vntData = rngList.Offset(i).Resize(, clngColumns).Value
      '探索Keyの作成
      vntKey = CStr(vntData(1, 1)) _
              & vbTab & CStr(vntData(1, 2)) _
                  & vbTab & CStr(vntData(1, 3)) '★変更
      'IndexにKeyが有る場合
      If .Exists(vntKey) Then
        'Sheet2からデータ部分を配列に取得
        vntResult = rngResult.Offset(.Item(vntKey), 3) _
                .Resize(, clngColumns - 3).Value '★変更
        'データを集計
        For j = 1 To UBound(vntResult, 2)
          vntResult(1, j) = Val(vntResult(1, j)) _
                      + Val(vntData(1, j + 2))
        Next j
        '集計配列を元の位置に出力
        rngResult.Offset(.Item(vntKey), 3) _
          .Resize(, clngColumns - 3).Value = vntResult '★変更
        
      Else
        'Sheet1の1行をSheet2にCopy
        rngList.Offset(i).Resize(, clngColumns).Copy _
              Destination:=rngResult.Offset(lngRow)
        'IndexにKeyとSheet2の出力行位置を登録
        .Item(vntKey) = lngRow
        '出力行位置を更新
        lngRow = lngRow + 1
      End If
    Next i
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  Set dicIndex = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

0 hits

【33095】シート1からシート2に対してグループ化集計 MoritaK 06/1/2(月) 17:55 質問
【33096】Re:シート1からシート2に対してグルー... kobasan 06/1/2(月) 19:02 発言
【33098】Re:シート1からシート2に対してグループ... Hirofumi 06/1/2(月) 19:57 回答
【33181】Re:シート1からシート2に対してグループ... MoritaK 06/1/4(水) 17:41 質問
【33182】Re:シート1からシート2に対してグループ... Hirofumi 06/1/4(水) 17:59 発言
【33190】Re:シート1からシート2に対してグループ... MoritaK 06/1/4(水) 19:34 質問
【33199】Re:シート1からシート2に対してグループ... Hirofumi 06/1/4(水) 20:55 回答
【33221】Re:シート1からシート2に対してグルー... 小僧 06/1/5(木) 13:00 回答
【33253】Re:シート1からシート2に対してグルー... MoritaK 06/1/5(木) 22:08 お礼

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