| |
>hirofumi様にもう一つお聞きしたいのですが出力のさいに
>できれば行列を入れ替えたいのですが可能でしょうか？
「Sub Sample2」(AdvancedFilter版)のコードは、
出力もAdvancedFilterに依存していますので無理です
ただし、「Sub Sample」の方は、行列を入れ替える方法を採れば可能です
Option Explicit
Public Sub Sample3()
'◆Listのデータ列数（A列〜AG列）
Const clngColumns As Long = 33
'◆「1係」の列位置を指定(基準セル位置からの列Offset：基準がA1で「1係」がD列なら3)
Const clngBegin As Long = 3
'◆「日付」の列位置を指定(基準セル位置からの列Offset：基準がA1で「日付」がA列なら0)
Const clngDate As Long = 0
'◆「店舗」の列位置を指定(基準セル位置からの列Offset：基準がA1で「店舗」がB列なら1)
Const clngKey As Long = 1
'◆「項目」の列位置を指定(基準セル位置からの列Offset：基準がA1で「項目」がC列なら2)
Const clngItem As Long = 2
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntDate As Variant
Dim vntKeys As Variant
Dim vntItems As Variant
Dim rngResult As Range
Dim vntResult As Variant
Dim vntData As Variant
Dim vntKeyA1 As Variant
Dim vntKeyB1 As Variant
Dim lngTop As Long
Dim lngCount As Long
Dim lngIndex As Long
Dim strProm As String
'◆Listの先頭セル位置を基準とする（列見出し「日付」のセル位置）
Set rngList = Worksheets("List").Cells(1, "A")
'◆List2の先頭セル位置を基準とする（列見出し「日付」のセル位置）
Set rngResult = Worksheets("List2").Cells(5, "A")
'結果表の出力を右1列ずらす例
' Set rngResult = Worksheets("List2").Cells(5, "B")
With rngResult
'先回の結果をクリア
.CurrentRegion.ClearContents '★変更
'「日付」の抽出条件を取得
vntKeyA1 = .Parent.Cells(2, 2).Value
'「店舗」の抽出条件を取得
vntKeyB1 = .Parent.Cells(3, 2).Value
End With
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim vntData(1 To lngRows, 1 To 1)
For i = 1 To lngRows
vntData(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns) _
.Resize(lngRows).Value = vntData
'データを「店舗」昇順の「日付」昇順で整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngKey), Order1:=xlAscending, _
Key2:=.Offset(1, clngDate), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'「日付」列データを配列に取得
vntDate = .Offset(1, clngDate).Resize(lngRows + 1).Value
'「店舗」列データを配列に取得
vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
'「項目」列データを配列に取得
vntItems = .Offset(1, clngItem).Resize(lngRows + 1).Value
End With
'結果出力用配列を確保(売上と差益の累計値の集計用)
ReDim vntResult(clngColumns - clngBegin, 1) '★変更
vntResult(0, 0) = "売上累計" '★変更
vntResult(0, 1) = "差益累計" '★変更
'Listのデータ行全てに就いて繰り返し
For i = 1 To lngRows
'「店舗」の値がKeyB1の値と合致した場合
If StrComp(vntKeys(i, 1), vntKeyB1, vbTextCompare) = 0 Then
'「日付」がKeyA1の値以下の場合
If vntDate(i, 1) <= vntKeyA1 Then
'項目が「売上」か"差益"なら
If vntItems(i, 1) = "売上" Or vntItems(i, 1) = "差益" Then
'1行分データを配列に取得
vntData = rngList.Offset(i, clngBegin) _
.Resize(, clngColumns - clngBegin).Value
'項目が「売上」なら
If vntItems(i, 1) = "売上" Then
lngIndex = 0
Else
lngIndex = 1
End If
'「係」 単位に集計
For j = 1 To clngColumns - clngBegin
vntResult(j, lngIndex) _
= vntResult(j, lngIndex) + vntData(1, j) '★変更
Next j
End If
'「日付」がKeyA1の値合致し、lngTopが0の場合
If vntDate(i, 1) = vntKeyA1 And lngTop = 0 Then
'抽出行の先頭行位置を記録
lngTop = i
'抽出行数を1に
lngCount = 1
Else
'抽出行数を更新
lngCount = lngCount + 1
End If
End If
Else
'探索するKeyB1を通り過ぎた場合
If lngTop > 0 Then
'Forを抜ける
Exit For
End If
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False
'結果を出力
With rngResult
'抽出結果が有るなら
If lngTop > 0 Then
'結果出力用配列を確保
ReDim vntItems(1 To clngColumns - 1, lngCount) '★追加
'列見出しを配列に取得
vntData = rngList.Offset(, 1).Resize(lngCount, _
clngColumns - 1).Value '★変更
'列見出しを行列変換して結果出力用配列に格納
For i = 1 To clngColumns - 1 '★追加
vntItems(i, 0) = vntData(1, i) '★追加
Next i '★追加
'抽出結果を配列に取得
vntData = rngList.Offset(lngTop, 1) _
.Resize(lngCount, clngColumns - 1).Value '★変更
'データを行列変換して結果出力用配列に格納
For i = 1 To clngColumns - 1 '★追加
For j = 1 To lngCount '★追加
vntItems(i, j) = vntData(j, i) '★追加
Next j '★追加
Next i '★追加
'結果を出力
.Resize(clngColumns - 1, _
lngCount + 1).Value = vntItems '★追加
.Offset(clngBegin - 2, lngCount + 1) _
.Resize(clngColumns - clngBegin + 1, _
2).Value = vntResult '★追加
strProm = "処理が完了しました"
Else
strProm = "抽出結果が有りません"
End If
End With
With rngList
'Listの再整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'Key列の削除
.Offset(1, clngColumns).EntireColumn.Delete
End With
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 07/5/5(土) 23:37 -
