| |
以前オートフィルタについて教えて頂いた者です その節はまことにありがとうございました
またお聞きしたいのですが
日々データを下記のように入力しております
シート1（List1)
日付 店舗 項目 1係 2係 3係
20070401 本店 売上 1 1 1
20070401 本店 差益 2 2 2
20070401 本店 在庫 3 3 3
20070401 支店A 売上 4 4 4
20070401 支店A 差益 5 5 5
20070401 支店A 在庫 6 6 6
20070401 支店B 売上 7 7 7
20070401 支店B 差益 8 8 8
20070401 支店B 在庫 9 9 9
20070402 本店 売上 1 1 1
20070402 本店 差益 2 2 2
20070402 本店 在庫 3 3 3
20070402 支店A 売上 4 4 4
20070402 支店A 差益 5 5 5
20070402 支店A 在庫 6 6 6
20070402 支店B 売上 7 7 7
20070402 支店B 差益 8 8 8
20070402 支店B 在庫 9 9 9
これを月別・店別・項目別・係別で集計したいのですが
オートフィルタで可能でしょうか？
出力したい表は下記のレイアウトです（本店売上）
A B C D
1
2
3 係 4月 5月
4 06年実績
5 07年目標
6 01係 07年実績
7 前年比
8 達成率
9 06年実績
10 07年目標
11 02係 07年実績
12 前年比
13 達成率
現在こちらのサイトで検索して似通ったサンプルがありましたので勝手ながら
使わして頂いております
Public Sub CrossTabulation()
'データ列数(A列〜C列)
Const clngColumns As Long = 3
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim rngResult As Range
Dim rngDate As Range
Dim rngScope As Range
Dim lngColumn As Long
Dim lngRow As Long
Dim vntMonth As Variant
Dim strProm As String
'データListの左上隅セル位置を基準として設定(列見出しの「日付」セル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Offset(1).Resize(lngRows + 1, clngColumns).Value
End With
'結果出力シートのA1セルを基準とする（Listの左上隅）
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
With rngResult
'日付の書かれている列数を取得
lngColumn = .Offset(, Columns.Count - _
.Column).End(xlToLeft).Column - .Column
'日付列の範囲を取得
If lngColumn > 0 Then
Set rngDate = .Offset(, 1).Resize(, lngColumn)
End If
'品名が有る行数を取得
lngRow = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'品名が有る範囲を取得
If lngRow > 0 Then
Set rngScope = .Offset(1).Resize(lngRow)
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'データの最終行まで繰り返し
For i = 1 To lngRows
'日付のシリアル値から月初の値を取得
vntMonth = DateSerial(Year(vntData(i, 1)), Month(vntData(i, 1)), 1)
'日付を探索
lngColumn = GetColumnPos(vntMonth, rngDate, rngResult)
'品名を探索
lngRow = GetRowPos(vntData(i, 2), rngScope, rngResult)
'日付、品名の交差するセルに値を書き込み
With rngResult.Offset(lngRow, lngColumn)
.NumberFormatLocal = "#,##0;""▲ ""#,##0"
.Value = .Value + vntData(i, 3)
End With
Next i
strProm = "処理が完了しました"
'データListの左上隅セル位置を基準として設定(列見出しの「日付」セル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Offset(1).Resize(lngRows + 1, clngColumns).Value
End With
'結果出力シートのA1セルを基準とする（Listの左上隅）
Set rngResult = Worksheets("Sheet2").Cells(12, "A")
With rngResult
'日付の書かれている列数を取得
lngColumn = .Offset(, Columns.Count - _
.Column).End(xlToLeft).Column - .Column
'日付列の範囲を取得
If lngColumn > 0 Then
Set rngDate = .Offset(, 1).Resize(, lngColumn)
End If
'品名が有る行数を取得
lngRow = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'品名が有る範囲を取得
If lngRow > 0 Then
Set rngScope = .Offset(1).Resize(lngRow)
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'データの最終行まで繰り返し
For i = 1 To lngRows
'日付のシリアル値から月初の値を取得
vntMonth = DateSerial(Year(vntData(i, 1)), Month(vntData(i, 1)), 1)
'日付を探索
lngColumn = GetColumnPos(vntMonth, rngDate, rngResult)
'品名を探索
lngRow = GetRowPos(vntData(i, 2), rngScope, rngResult)
'日付、品名の交差するセルに値を書き込み
With rngResult.Offset(lngRow, lngColumn)
.NumberFormatLocal = "#,##0;""▲ ""#,##0"
.Value = .Value + vntData(i, 4)
End With
Next i
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set rngScope = Nothing
Set rngDate = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetColumnPos(vntDate As Variant, _
rngScope As Range, _
rngDateTop As Range) As Long
Dim lngFound As Long
Dim lngOver As Long
Dim lngCount As Long
'日付範囲に日付が無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
lngOver = 1
Else
'日付の探索
'セル値が数値として入力されている場合
lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
'セル値が文字列として入力されている場合
' lngFound = DataSearch(vntDate, rngScope, lngOver)
lngCount = rngScope.Columns.Count
End If
'日付が見つかった場合
If lngFound > 0 Then
'位置を返す
GetColumnPos = lngFound
Else
With rngDateTop
'日付が最終列の以内の場合
If lngOver <= lngCount Then
'指定位置に列を挿入
.Offset(, lngOver).EntireColumn.Insert
End If
'日付を書き込み
With .Offset(, lngOver)
.NumberFormatLocal = "yyyy/m"
' .NumberFormatLocal = "m""月"""
.Value = vntDate
End With
'挿入位置を返す
GetColumnPos = lngOver
'日付列の範囲を更新
Set rngScope = .Offset(, 1).Resize(, lngCount + 1)
End With
End If
End Function
Private Function GetRowPos(vntKey As Variant, _
rngScope As Range, _
rngListTop As Range) As Long
Dim lngFound As Long
Dim lngCount As Long
'品名範囲に品名が無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
Else
'品名を探索
lngFound = DataSearch(vntKey, rngScope, , 0)
lngCount = rngScope.Rows.Count
End If
'探索成功（品名が有るなら）
If lngFound > 0 Then
'位置を返す
GetRowPos = lngFound
Else
With rngListTop
'行末位置を更新
lngCount = lngCount + 1
'セルの書式を文字列に設定
'(001の様な場合無いと探索が出来ない）
.Offset(lngCount).NumberFormatLocal = "@"
'行末に品名を書き込み
.Offset(lngCount).Value = vntKey
'挿入位置を返す
GetRowPos = lngCount
'探索範囲の更新
Set rngScope = .Offset(1).Resize(lngCount)
End With
End If
End Function
Private Function DataSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long, _
Optional lngMode As Long = 1) As Long
Dim vntFind As Variant
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngMode)
lngOver = 1
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
DataSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
End If
End Function
このコードで、店舗と項目を結合さして07年の１係の実績は表示できるのですが
店舗と項目を指定して1係〜30係まで月別集計を出力できるでしょうか
上記に示しました表は本店の売上を指定したときのレイアウトです
わかりにくい説明で申し訳ありません
よろしくお願いいたします
|
|
hiro
- 07/5/20(日) 23:52 -
