| |
レイアウト有り難う御座います
今回の場合､データ列数と､振り分けに使用するKeyの列は決まっている様なので固定して居ます
また、データ元が「元帳DB」で入力フォームでは無さそうなので、
作られる仕分シートは一過性の物として、マクロが実行される毎ににクリアされます
元帳DBには、列見出しが有る物とします
元帳DBは、実行時に抽出Keyで整列され終了直前に元の行位置に再整列されます
勘定項目、日付、集計列の位置は、rngListを基準とした列Offsetとします
例えば、A1(列見出し「a1」)を基準とすると、A列は0、B列は1、C列は2
Option Explicit
Option Compare Text
Public Sub Sample2()
'元帳DBのデータ列数（A列〜H列）
Const clngColumns As Long = 8
'元帳DBの勘定項目列(基準セル位置「A列」からの列Offset「H列」)
Const clngGroup As Long = 7
'元帳DBの日付列(基準セル位置「A列」からの列Offset「B列」)
Const clngDate As Long = 1
'元帳DBの集計列(基準セル位置「A列」からの列Offset「E列」)
Const clngSum As Long = 4
'結果出力シートの先頭位置
Const cstrTop As String = "A1"
Dim i As Long
Dim lngRows As Long
Dim lngRow As Long
Dim lngTop As Long
Dim lngCount As Long
Dim rngList As Range
Dim rngResult As Range
Dim rngHeader As Range
Dim vntGroup As Variant
Dim vntColumnWidth As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする（列見出し「a1」のセル位置）
Set rngList = Worksheets("元帳DB").Cells(1, "A")
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, _
clngGroup).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
'データを抽出昇順の日付昇順で整列
DataSort .Offset(1).Resize(lngRows, _
clngColumns + 1), .Offset(, clngDate)
DataSort .Offset(1).Resize(lngRows, _
clngColumns + 1), .Offset(, clngGroup)
'抽出Keyデータを配列に取得
vntGroup = .Offset(1, clngGroup) _
.Resize(lngRows + 1).Value
'列見出し範囲を取得
Set rngHeader = .Resize(, clngColumns)
'列幅を取得
ReDim vntColumnWidth(clngColumns - 1)
For i = 0 To clngColumns - 1
vntColumnWidth(i) _
= .Offset(, i).EntireColumn.ColumnWidth
Next i
End With
'仮に結果と元表を同じにして置く
Set rngResult = rngList
'注目値の位置を記録
lngTop = 1
'データ行数のカウント初期値
lngCount = 1
For i = 2 To lngRows + 1
'注目値と現在値が違った場合
If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
'出力シートを設定
GetSheets CStr(vntGroup(lngTop, 1)), cstrTop, _
rngResult, rngHeader, vntColumnWidth, clngDate
With rngResult
'データを転記
rngList.Offset(lngTop).Resize(lngCount, _
clngColumns).Copy Destination:=.Offset(1)
'日付毎に集計
.CurrentRegion.Subtotal _
GroupBy:=clngDate + 1, Function:=xlSum, _
TotalList:=clngSum + 1, Replace:=True, _
PageBreaks:=False, SummaryBelowData:=True
End With
'注目値の位置を記録
lngTop = i
'データ行数のカウント初期値に
lngCount = 1
Else
'データ行数のカウントを更新
lngCount = lngCount + 1
End If
Next i
With rngList
'元データを復帰
DataSort .Offset(1).Resize(lngRows, _
clngColumns + 1), .Offset(1, clngColumns)
'復帰用Key列を削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set rngHeader = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub GetSheets(strName As String, _
strTop As String, _
rngResult As Range, _
rngHeader As Range, _
vntWidth As Variant, _
lngDate As Long)
Dim i As Long
Dim lngRows As Long
Dim wksMark As Worksheet
'シートの存在確認
For Each wksMark In Worksheets
If StrComp(wksMark.Name, strName, vbTextCompare) = 0 Then
Exit For
End If
Next wksMark
'もし、シートが無いなら
If wksMark Is Nothing Then
'シートを追加して、シート名を設定
Set wksMark = Worksheets.Add(After:=rngResult.Parent)
On Error Resume Next
wksMark.Name = strName
On Error GoTo 0
End If
'シートのstrTopを出力基準セル位置とする
Set rngResult = wksMark.Range(strTop)
With rngResult
'行数の取得
lngRows = .Offset(Rows.Count - .Row, _
lngDate).End(xlUp).Row - .Row
'シートにデータが無い場合
If lngRows <= 0 Then
'列幅を設定
For i = 0 To UBound(vntWidth, 1)
.Offset(, i).EntireColumn.ColumnWidth = vntWidth(i)
Next i
'列見出しを出力
rngHeader.Copy Destination:=.Offset
Else
'Subtotalを解除
.CurrentRegion.RemoveSubtotal
'シートのデータを消去
.Offset(1).Resize(lngRows, _
UBound(vntWidth, 1) + 1).ClearContents
End If
End With
Set wksMark = Nothing
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|
Hirofumi
- 06/9/30(土) 6:46 -
