|
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
|
|