Excel VBA質問箱 IV

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

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


66273 / 76734 ←次へ | 前へ→

【15026】Re:集計表の作成について
回答  Hirofumi  - 04/6/13(日) 19:51 -

引用なし
パスワード
   Sheet1

   A  B  C  D  E  F  G   H   I   J
 1 課名 項1 項2 項3 項4 項5 費目  4月  5月  6月
 2 1課  A  B  C  D  E  ▲   1  11  21
 3 1課  A  B  C  D  E  △   2  12  22
 4 1課  A  B  C  D  E  ●   3  13  23
 5 1課  A  B  C  D  E  ○   4  14  24
 6 1課  A  B  C  D  E  ■   5  15  25
 7 1課  A  B  C  D  E  □   6  16  26
 8 1課  A  B  C  D  E  ◆   7  17  27
 9 1課  A  B  C  D  E  ◇   8  18  28
10 1課  A  B  C  D  E  ★   9  19  29
11 1課  A  B  C  D  E  ☆  10  20  30
12 2課  F  G  H  I  J  ▲  11  21  31
13 2課  F  G  H  I  J  △  12  22  32
14 2課  F  G  H  I  J  ●  13  23  33
15 2課  F  G  H  I  J  ○  14  24  34
16 2課  F  G  H  I  J  ■  15  25  35
17 2課  F  G  H  I  J  □  16  26  36
18 2課  F  G  H  I  J  ◆  17  27  37

Sheet2
  A  B  C  D  E  F   G   H   I
                     4月
1 課名 項1 項2 項3 項4 項5  ▲   △   ●
2 1課  A  B  C  D  E   1   2   3
3 2課  F  G  H  I  J  11  12  13
4 3課  K  L  M  N  O  21  22  23

と言う形で組直しました
変更を見れば解る通り、単純に「何処を直せば?」
と言う訳には行きません

元のデータ形式の変更、結果の形式の変更は、簡単に行きません
今回は、真だ少ない方だと思います

Option Explicit

Public Sub AddUp()

  Const lngItem As Long = 10   '費目数       ★この行追加
  Const lngInfor As Long = 6   '課名等の列情報を6個 ★この行追加
  
  Dim i As Long
  Dim rngData As Range
  Dim lngRow As Long
  Dim lngCol As Long
  Dim rngResult As Range
  
  '結果表の左上セル位置を設定
  Set rngResult _
    = Worksheets("Sheet2").Cells(1, "A")
  'データ表の左上セル位置を設定
  Set rngData _
    = Worksheets("Sheet1").Cells(1, "A")
  
  'データ表に就いて
  With rngData
    '月列の数を取得
    lngCol = .End(xlToRight).Column _
          - .Offset(, lngInfor + 1).Column  '★この行変更
    'データ行数を取得
    lngRow = .Offset(, 1).End(xlDown).Row _
              - .Offset(, 1).Row     '★この行変更
  End With
  
  '行見だしを作成
  WriteRowTitle rngData, rngResult, _
          lngRow, lngItem, lngInfor      '★この行変更
  
  '月の列の先頭から最後まで繰り返し
  For i = 0 To lngCol
    '月別に集計
    ListWrite i, rngData, rngResult, _
          lngRow, lngItem, lngInfor
  Next i
  
  Set rngData = Nothing
  Set rngResult = Nothing

  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Sub ListWrite(ByVal lngRead As Long, _
            rngData As Range, _
            rngResult As Range, _
            lngRow As Long, _
            lngItem As Long, _
            lngInfor As Long)        '★この行変更

  Dim i As Long
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim lngWrite As Long                '★この行追加
  
  '読み込み位置を書き込み列位置に変換
  lngWrite = lngRead * lngItem + lngInfor       '★この行追加
  '読み込み位置を列位置(Offset位置)変換
  lngRead = lngRead + lngInfor + 1          '★この行追加
  
  '出力用配列を確保
  ReDim vntResult(0 To lngRow \ lngItem + 1, _
                0 To lngItem - 1)    '★この行変更
  
  'データ表の左上セルに就いて
  With rngData
    '月名を出力用配列に代入
    vntResult(0, 0) _
        = .Offset(, lngRead).Value       '★この行変更
    '費目を出力用配列に代入
    For i = 1 To lngItem              '★この行追加
      vntResult(1, i - 1) _
          = .Offset(i, lngInfor).Value    '★この行変更
    Next i                     '★この行追加
    'データを配列に取得
    vntData _
      = .Offset(1, lngRead).Resize(lngRow).Value '★この行変更
  End With
  
  'データを出力用配列に書き込み
  For i = 1 To UBound(vntData)
    vntResult((i - 1) \ lngItem + 2, _
          (i - 1) Mod lngItem) _
                = vntData(i, 1)     '★この行変更
  Next i
  
  '出力用配列を出力
  With rngResult.Offset(, lngWrite) '★この行変更
    .Resize(lngRow \ lngItem + 2, _
          lngItem).Value = vntResult     '★この行変更
  End With
  
End Sub

Private Sub WriteRowTitle(rngData As Range, _
            rngResult As Range, _
            lngRow As Long, _
            lngItem As Long, _
            lngInfor As Long)        '★この行変更
            
  Dim i As Long
  Dim j As Long                    '★この行追加
  Dim k As Long                    '★この行追加
  Dim vntData As Variant
  Dim vntResult As Variant
  
  '出力用配列を確保
  ReDim vntResult(0 To lngRow \ lngItem + 1, _
                  0 To lngInfor - 1) '★この行変更
  'データ表の左上セルに就いて
  With rngData
    'データを配列に取得
    vntData = .Resize(lngRow + 1, lngInfor).Value  '★この行変更
  End With
  
  '課名を出力用配列に代入
  For i = 1 To lngInfor                '★この行追加
    vntResult(1, i - 1) = vntData(1, i)       '★この行変更
  Next i                       '★この行追加
  '課を出力用配列に代入
  k = 2                        '★この行追加
  For i = 2 To UBound(vntData)            '★この行変更
    If vntResult(k - 1, 0) <> vntData(i, 1) Then  '★この行追加
      For j = 1 To lngInfor            '★この行追加
        vntResult(k, j - 1) = vntData(i, j)   '★この行変更
      Next j                   '★この行追加
      k = k + 1                  '★この行追加
    End If                     '★この行追加
  Next i
  
  '出力用配列を出力
  rngResult.Resize(lngRow \ lngItem + 2, _
              lngInfor).Value = vntResult '★この行変更
  
End Sub

1 hits

【15001】集計表の作成について 美咲 04/6/13(日) 1:42 質問
【15004】Re:集計表の作成について Hirofumi 04/6/13(日) 9:47 回答
【15021】Re:集計表の作成について 美咲 04/6/13(日) 16:07 質問
【15022】Re:集計表の作成について Hirofumi 04/6/13(日) 16:42 回答
【15026】Re:集計表の作成について Hirofumi 04/6/13(日) 19:51 回答
【15030】Re:集計表の作成について 美咲 04/6/13(日) 22:37 お礼

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