Excel VBA質問箱 IV

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

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


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

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

【33095】シート1からシート2に対してグループ化...
質問  MoritaK  - 06/1/2(月) 17:55 -

引用なし
パスワード
   こんにちは
 Accessの環境では「グループ化」集計を簡単に行えますけれど、同じフィールで
Excel環境で「グループ化」集計を行う場合は、可能でしょうか?

Sheet1
年月日    検疫サンプル名  24:00  06:00  12:00  18:00  計
20051201   prokih-hkc001  20    10    18    22   70
20051201   prokih-hkc111  20    10    18    20   68
20051201   prokih-hkc001  20    10    18    22   70




sheet2
年月日    検疫サンプル名  24:00  06:00  12:00  18:00  計
20051201   prokih-hkc001  40    20    36    44   140
20051201   prokih-hkc111  20    10    18    20   68





      

【33096】Re:シート1からシート2に対してグルー...
発言  kobasan  - 06/1/2(月) 19:02 -

引用なし
パスワード
   MoritaK さん、皆さん、明けましておめでとうございます。

似たような質問がありましたので参考にしてください。

【29835】Re:データの小計をだしたい
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=29835;id=excel

を参考にしてください

【33098】Re:シート1からシート2に対してグルー...
回答  Hirofumi  - 06/1/2(月) 19:57 -

引用なし
パスワード
   Sheet1が以下の様に成って居るとします
   A      B         C    D    E    F   G
1  年月日    検疫サンプル名  24:00  06:00  12:00  18:00  計
2  20051201   prokih-hkc001   20   10    18    22   70
3  20051201   prokih-hkc111   20   10    18    20   68
4  20051201   prokih-hkc001   20   10    18    22   70
5  ・

Option Explicit

Public Sub Sample()

  'データ列数
  Const clngColumns As Long = 7
  
  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))
      'IndexにKeyが有る場合
      If .Exists(vntKey) Then
        'Sheet2からデータ部分を配列に取得
        vntResult = rngResult.Offset(.Item(vntKey), 2) _
                .Resize(, clngColumns - 2).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), 2) _
            .Resize(, clngColumns - 2).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

【33181】Re:シート1からシート2に対してグルー...
質問  MoritaK  - 06/1/4(水) 17:41 -

引用なし
パスワード
   Hirofumiさん
 いただいたコードを実行しました。
 成功です。
 最後の質問になりますが、よろしくお願いします。
ブックのレイアウトは、
No01  No02  No03 ・・・No07   No08 ・・・・・・・・No27

No01〜No07→Group byのkeyとして
No08〜No27→グループ化合計

 

【33182】Re:シート1からシート2に対してグルー...
発言  Hirofumi  - 06/1/4(水) 17:59 -

引用なし
パスワード
   > 最後の質問になりますが、よろしくお願いします。
>ブックのレイアウトは、
>No01  No02  No03 ・・・No07   No08 ・・・・・・・・No27
>
>No01〜No07→Group byのkeyとして
>No08〜No27→グループ化合計

?現状は、同一「年月日」の同一「検疫サンプル名」の同じ列を
単純に合計しているだけですが?
此れの延長で列数が増えただけなら以下の修正で済みますが?

  'データ列数
  Const clngColumns As Long = 7



  'データ列数
  Const clngColumns As Long = 29

にする

こう言う事で無いなら、Sheet2の結果がどうなるのか?、
どう言う計算をするのか?、Upして下さい

【33190】Re:シート1からシート2に対してグルー...
質問  MoritaK  - 06/1/4(水) 19:34 -

引用なし
パスワード
   Hirofumiさん
 集計のキーに「検疫所」を加えた場合は、どのように対応すれば、いいでしょうか?
 
Sheet1
年月日  検疫所  検疫サンプル名  24:00  06:00  12:00  18:00  計
20051201 北海道  prokih-hkc001  20    10    18     22   70
20051201 愛知   prokih-hkc111  20    10    18     20   68
20051201 北海道  prokih-hkc001  20    10    18    22   70



結果:
sheet2
年月日  検疫所  検疫サンプル名  24:00  06:00  12:00  18:00  計
20051201 北海道  prokih-hkc001  40    20    36    44   140
20051201 愛知   prokih-hkc111  20    10    18    20    68




【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

【33221】Re:シート1からシート2に対してグルー...
回答  小僧  - 06/1/5(木) 13:00 -

引用なし
パスワード
   ▼MoritaKさん、Hirofumi さん:
こんにちは。

>Accessの環境では「グループ化」集計を簡単に行えますけれど、

Access にお慣れでしたら、SQL で解決も可能ですね。

Sub SQLで()
Dim strSQL As String
Dim ADORS As Object
Dim ADOCon As Object
Dim i As Long

  On Error Resume Next
  
  Set ADOCon = CreateObject("ADODB.Connection")
    ADOCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & ThisWorkbook.FullName & ";" & _
          "Extended Properties=Excel 8.0;"
    If Err.Number <> 0 Then MsgBox "ADO接続に失敗": Exit Sub
    
  On Error GoTo 0
      
  strSQL = "SELECT 年月日, 検疫所, 検疫サンプル名, " _
      & "Sum([24:00]) AS [24:00の合計], " _
      & "Sum([6:00]) AS [6:00の合計], " _
      & "Sum([12:00]) AS [12:00の合計], " _
      & "Sum([18:00]) AS [18:00の合計], " _
      & "Sum(計) AS 計の合計 " _
      & "From [Sheet1$] " _
      & "GROUP BY 年月日, 検疫所, 検疫サンプル名;"

  Set ADORS = ADOCon.Execute(strSQL)
  
    With Sheets("Sheet2")
      For i = 0 To ADORS.Fields.Count - 1
        .Cells(1, i + 1).Value = ADORS(i).Name
      Next
      .Range("A2").CopyFromRecordset ADORS
    End With
  ADORS.Close: Set ADORS = Nothing
  ADOCon.Close: Set ADOCon = Nothing
End Sub

【33253】Re:シート1からシート2に対してグルー...
お礼  MoritaK  - 06/1/5(木) 22:08 -

引用なし
パスワード
   kobasanさん
hirofumiさん
小僧さん
 問題解決しました。
 初心者の私にいろいろなご指導をいただき、本当にありがとうございました。

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