| |
Sheet1
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ Ｉ Ｊ
１ 課名 項１ 項２ 項３ 項４ 項５ 費目 ４月 ５月 ６月
２ １課 Ａ Ｂ Ｃ Ｄ Ｅ ▲ １ １１ ２１
３ １課 Ａ Ｂ Ｃ Ｄ Ｅ △ ２ １２ ２２
４ １課 Ａ Ｂ Ｃ Ｄ Ｅ ● ３ １３ ２３
５ １課 Ａ Ｂ Ｃ Ｄ Ｅ ○ ４ １４ ２４
６ １課 Ａ Ｂ Ｃ Ｄ Ｅ ■ ５ １５ ２５
７ １課 Ａ Ｂ Ｃ Ｄ Ｅ □ ６ １６ ２６
８ １課 Ａ Ｂ Ｃ Ｄ Ｅ ◆ ７ １７ ２７
９ １課 Ａ Ｂ Ｃ Ｄ Ｅ ◇ ８ １８ ２８
１０ １課 Ａ Ｂ Ｃ Ｄ Ｅ ★ ９ １９ ２９
１１ １課 Ａ Ｂ Ｃ Ｄ Ｅ ☆ １０ ２０ ３０
１２ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ ▲ １１ ２１ ３１
１３ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ △ １２ ２２ ３２
１４ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ ● １３ ２３ ３３
１５ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ ○ １４ ２４ ３４
１６ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ ■ １５ ２５ ３５
１７ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ □ １６ ２６ ３６
１８ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ ◆ １７ ２７ ３７
Sheet2
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ Ｉ
４月
１ 課名 項１ 項２ 項３ 項４ 項５ ▲ △ ●
２ １課 Ａ Ｂ Ｃ Ｄ Ｅ １ ２ ３
３ ２課 Ｆ Ｇ Ｈ Ｉ Ｊ １１ １２ １３
４ ３課 Ｋ Ｌ Ｍ Ｎ Ｏ ２１ ２２ ２３
と言う形で組直しました
変更を見れば解る通り、単純に「何処を直せば？」
と言う訳には行きません
元のデータ形式の変更、結果の形式の変更は、簡単に行きません
今回は、真だ少ない方だと思います
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
|
|
Hirofumi
- 04/6/13(日) 19:51 -
