◎申し訳ありません
作成途上に放棄したものにつきなんの参考にもなりません
----------------------------------------------
Option Explicit
Option Base 1
Option Private Module
'汎用的に使える関数を記載する
'集計関係のモジュールを記述
'ステータスを格納する構造体を定義
'A:Alpabet N:Numeric
Private Type codeFormat
GroupID As Integer 'グループの数
Code As String * 10 'なんらかのコード(10文字の文字列とする)
EXstat As String * 1 '「存在ステータス」("Y" or "N")
DPstat As String * 2 '「重複状況」("OK" or "NG")
Stotal As Long '「小計」(Num)
Combined As String '複合キー
End Type
Public Function CreateSummarySheet(Optional ByVal SmryShtName As String = SMRY_SHT_NAME, _
Optional ByVal CtrlShtName As String = CTRL_SHT_NAME) As Boolean
'集計シートを作成する関数
Dim strSheetName As String '
Dim bolFlg As Boolean
Dim shtIndex As Integer
Dim wksSheet As Worksheet
'エラーハンドリング
On Error GoTo Hdl_ERROR
'シートがあったら削除する
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name = SmryShtName Then
Call DeleteSheet(SmryShtName, ThisWorkbook.Name)
Exit For
End If
Next wksSheet
'操作シートの次に新しいシートを挿入するためインデックスを取得
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name = CtrlShtName Then
shtIndex = wksSheet.Index
Exit For
End If
Next wksSheet
'シート作成が成功したらコマンドボタンを作成する
If shtIndex <> 0 Then
Set wksSheet = Sheets.Add(after:=Worksheets(shtIndex))
wksSheet.Name = SmryShtName
bolFlg = MakeCommandButton(wksSheet, 432.75, 14.25, 103.5, 22.5, "CMD_SUMMARY", "集計")
Else
CreateSummarySheet = False
Exit Function
End If
'結果の判定
If bolFlg <> False Then
CreateSummarySheet = True
Exit Function
Else
GoTo Hdl_ERROR
End If
Hdl_ERROR:
'シートを削除
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name = SmryShtName Then
Call DeleteSheet(SmryShtName, ThisWorkbook.Name)
Exit For
End If
Next wksSheet
Set wksSheet = Nothing
CreateSummarySheet = False
End Function
Private Function MakeCommandButton(ByRef objTargetSheet As Worksheet, _
ByVal siLeft As Single, _
ByVal siTop As Single, _
ByVal siWidth As Single, _
ByVal siHeight As Single, _
ByVal strBtnName As String, _
ByVal strCaption As String) As Boolean
'指定シートの指定位置に指定名,指定キャプションでコマンドボタンを作成する
'※"MS Forms 2.0"をインクルード ＋
'[マクロ]->[セキュリティ]->[信頼のおける発行元]->[Visual Basic～]にチェック
Dim strCode As String '作成したシートに挿入するコード
'オブジェクト操作準備
objTargetSheet.Activate
objTargetSheet.Range("A1").Activate
'エラーハンドリング
On Error GoTo Hdl_ERROR
'コマンドボタン追加
With objTargetSheet.OLEObjects.Add("Forms.CommandButton.1", Link:=False, _
DisplayAsIcon:=False, Left:=siLeft, Top:=siTop, Width:=siWidth, Height:=siHeight)
.Name = strBtnName
.Object.Caption = strCaption
End With
Erase KsjData
KsjData = GetKSJDataInMemory(KSJ_SHT_NAME)
Call SetStatusInCode(Code_SHT_NAME, KSJ_SHT_NAME)
'コード作成
strCode = "Private Sub " & strBtnName & "_Click()" & vbCrLf
strCode = strCode & "End Sub"
'シートイベント追加
With ThisWorkbook.VBProject.VBComponents(objTargetSheet.CodeName).CodeModule
' 'シートモジュールにコード挿入
.InsertLines 1, strCode
End With
MakeCommandButton = True
Exit Function
Hdl_ERROR:
MsgBox "コマンドボタン生成中にエラーが起きました", vbCritical + vbOKOnly
MakeCommandButton = False
End Function
Public Function CreateSummaryData(Optional ByVal CodeSheetName = Code_SHT_NAME, _
Optional ByVal SmrySheetName = SMRY_SHT_NAME) As Long
'集計シートのデータを作成する
'引数1：コードが記載されているシート名
'引数2：集計シートのシート名
'戻値：処理行数
Dim wksCodeSheet As Worksheet 'コード記載シートのオブジェクト
Dim wksSmrSheet As Worksheet '集計シートのオブジェクト
Dim objRange As Range '合計用
Dim Count As Long 'インデックスカウンタ
Dim MinGid As Long 'グループIDの初期値
Dim NowGID As Long 'グループIDのインデックス
Dim MaxGID As Long 'グループIDの最大値
Dim CodeRowBgn As Long 'コード設定シートのデータ開始行
Dim CodeRowIdx As Long 'コードレベル設定シートのデータ現在行
Dim CodeRowMax As Long 'コードレベル設定シートのデータ最終行
Dim RowBgn As Long '構造体の開始インデックス
Dim RowIdx As Long '構造体の現在インデックス
Dim RowIdx2 As Long '構造体の現在インデックス(子ループ用)
Dim RowMax As Long '構造体の最終インデックス
Dim strWork1 As String '文字列判定用のワーク変数
Dim strWork2 As String ' 〃
Dim strBuf As String '読み込みバッファ
Dim strGID1 As String '重複の判定用
Dim strGID2 As String ' 〃
Dim DataStore() As codeFormat 'ステータスを格納する構造体
Dim SmryStore() As codeFormat 'グループをユニークにしたものを格納する構造体
'初期化
Set wksCodeSheet = ThisWorkbook.Worksheets(Code_SHT_NAME)
Set wksSmrSheet = ThisWorkbook.Worksheets(SMRY_SHT_NAME)
CodeRowBgn = 2 '行ラベルの次から
CodeRowMax = wksCodeSheet.UsedRange.Rows.Count
RowBgn = 1
MinGid = 1
If CodeRowMax >= CodeRowBgn Then
RowMax = CodeRowMax - CodeRowBgn + 1
Else
Err.Raise vbObjectError + 513, "MyProj.MyObject", _
"データがありません"
End If
'集計シートをクリアして列の書式設定をを「文字列」にする
wksSmrSheet.Activate
wksSmrSheet.Cells.Select
Selection.ClearContents
wksSmrSheet.Range(Columns(1), Columns(6)).NumberFormatLocal = "@" 'A列～F列
wksSmrSheet.Range("A1").Activate
'集計シートにタイトル行の作成
wksSmrSheet.Cells(1, 1).Value = "コード"
wksSmrSheet.Cells(1, 2).Value = "存在ステータス"
wksSmrSheet.Cells(1, 3).Value = "重複状況"
wksSmrSheet.Cells(1, 4).Value = "小計"
'構造体の動的宣言
ReDim DataStore(RowMax)
'構造体にコードデータをストア
RowIdx = RowBgn
For CodeRowIdx = CodeRowBgn To CodeRowMax Step 1
With DataStore(RowIdx)
.GroupID = 0 'グループID：とりあえず0埋め
.DPstat = "OK" '重複状態：とりあえず埋め
.Stotal = 0 '小計：とりあえず埋め
.EXstat = wksCodeSheet.Cells(CodeRowIdx, 5).Value '存在ステータス
.Code = wksCodeSheet.Cells(CodeRowIdx, 6).Value '判定対象コード
.Combined = .Code & .EXstat
'ステータスが空だったら処理しないフラグをつける
If Trim$(.EXstat) = "" Or Trim$(.Code) = "" Then
.Combined = "Z" '"Z"は処理対象外をあらわす
Else
.Combined = Trim(.EXstat & .Code) '複合キー
End If
End With
RowIdx = RowIdx + 1
Next
'複合キー(コードと存在ステータスを連結したもの)をカウント
Count = 1
NowGID = 1
MaxGID = NowGID
For RowIdx = RowBgn To RowMax Step 1 '親ループ
If RowIdx <> RowMax Then '親ループの最終行以外で
If DataStore(RowIdx).GroupID = 0 Then 'グループIDがセットされていないものが対象
DataStore(RowIdx).GroupID = NowGID
For RowIdx2 = RowBgn + 1 To RowMax Step 1 '子ループ
strWork1 = Trim(DataStore(RowIdx).Combined)
strWork2 = Trim(DataStore(RowIdx2).Combined)
If strWork1 = strWork2 Then '複合キーが一致したらグループIDをセットし
DataStore(RowIdx2).GroupID = NowGID
Count = Count + 1 'カウンタを増加
End If
strWork1 = ""
strWork2 = ""
Next
If Count > 0 Then '処理済データがあったならば
'カウンタをセットする関数を記載する
Call SetMaxCountTocodeFormat(DataStore, NowGID, Count)
End If
MaxGID = NowGID 'グループID最大値をセットし
NowGID = NowGID + 1 'グループIDを進める
End If
Else '親ループの最終行で
If DataStore(RowIdx).GroupID = 0 Then 'グループIDがセットされていないものに
MaxGID = NowGID 'グループID最大値をセットし
DataStore(RowIdx).GroupID = NowGID 'グループIDをセットする
DataStore(RowIdx).Stotal = 1 '当然カウンタは1になる
End If
End If
Count = 0
Next
'グループIDでユニークにしたデータを格納する構造体を宣言
ReDim SmryStore(MaxGID)
'グループIDごとにデータをコピーする
NowGID = MinGid
Do
For RowIdx = RowBgn To RowMax Step 1
If DataStore(RowIdx).GroupID = NowGID Then
With SmryStore(NowGID)
strWork1 = Trim(DataStore(RowIdx).Combined)
'対象外でないならデータをコピー
If strWork1 <> "Z" Then
.DPstat = DataStore(RowIdx).DPstat
.EXstat = DataStore(RowIdx).EXstat
.GroupID = DataStore(RowIdx).GroupID
.Code = DataStore(RowIdx).KSJcode
.Stotal = DataStore(RowIdx).Stotal
.Combined = "0" '次の重複判定処理のためのフラグとして"0"で埋め
Else
.DPstat = ""
.EXstat = ""
.GroupID = DataStore(RowIdx).GroupID
.Combined = strWork1 '"Z"を書き込む
End If
strWork1 = ""
End With
NowGID = NowGID + 1
Exit For
End If
Next
Loop Until NowGID = MaxGID + 1
'重複判定処理を行う(同じコードで違うGIDのものを重複とする)
For NowGID = MinGid To MaxGID Step 1
Count = 0 'カウンタ初期化
If NowGID <> MaxGID Then '最終行でない場合
strWork1 = Trim(SmryStore(NowGID).Combined)
strGID1 = SmryStore(NowGID).GroupID
If strWork1 = "0" Then '処理済でなかったならば子ループで重複を探す
SmryStore(NowGID).Combined = "1" '親を処理済にする
strWork1 = SmryStore(NowGID).KSJcode '比較元のコードをセット
For RowIdx = NowGID + 1 To MaxGID Step 1 '子ループを進める
strWork2 = SmryStore(RowIdx).KSJcode
strGID2 = SmryStore(RowIdx).GroupID
If strWork2 = strWork1 Then 'コードが一致したら
If strGID2 <> strGID1 Then '連結アクセス権の不一致を判定する
SmryStore(NowGID).DPstat = "NG" '
SmryStore(RowIdx).DPstat = "NG"
End If
End If
Next
End If
Else '最終行
strWork1 = Trim(SmryStore(NowGID).Combined)
strGID1 = SmryStore(NowGID).GroupID
If strWork1 = "0" Then
SmryStore(NowGID).DPstat = "OK"
End If
End If
Next
'データの書き出し
'A:コード'B:存在ステータス,C:重複状況,D:小計
Count = 0
For RowIdx = RowBgn To MaxGID Step 1
'ステータスが対象外でなければ書き込む
strWork1 = Trim$(SmryStore(RowIdx).Combined)
If strWork1 <> "Z" Then
With wksSmrSheet
'タイトル行すっ飛ばしのため行は一つ増やして書き込む
.Cells(RowIdx + 1, 1).Value = SmryStore(RowIdx).Code
.Cells(RowIdx + 1, 3).Value = SmryStore(RowIdx).EXstat
.Cells(RowIdx + 1, 4).Value = SmryStore(RowIdx).DPstat
.Cells(RowIdx + 1, 5).Value = SmryStore(RowIdx).Stotal
Count = Count + 1
End With
End If
Next
'ソートする
wksSmrSheet.Range(Cells(1, 1), Cells(MaxGID + 1, 5)).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range( _
"E2"), Order2:=xlDescending, Key3:=Range("C2"), Order3:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortTextAsNumbers, _
DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
'合計を埋める
Set objRange = wksSmrSheet.Range(Cells(2, 5), Cells(wksSmrSheet.UsedRange.Rows.Count, 5))
wksSmrSheet.Cells(2, 6).Value = WorksheetFunction.Sum(objRange)
CreateSummaryData = Count
End Function
Private Function SetMaxCountTocodeFormat(ByRef DataStore() As codeFormat, _
ByVal TargetGID As Long, _
ByVal MaxCount As Long) As Boolean
'集計用構造体の指定GIDの小計全てに指定の数値を書き込む
'引数1：集計用構造体をアドレス渡し
'引数2：グループID
'引数3：セットする数値
'戻値：成功=TRUE,失敗=FALSE
Dim BgnIdx As Long '構造体の配列要素の開始値
Dim CrtIdx As Long '構造体の配列要素の現在値
Dim MaxIdx As Long '構造体の配列要素の最終値
Dim Buf As Long 'ワーク用
'エラーハンドリング
On Error GoTo Hdl_ERROR
'初期化
BgnIdx = 1
MaxIdx = UBound(DataStore)
'データセット
For CrtIdx = BgnIdx To MaxIdx Step 1
Buf = DataStore(CrtIdx).GroupID
If Buf = TargetGID Then
DataStore(CrtIdx).Stotal = MaxCount
End If
Next
SetMaxCountTocodeFormat = True
Exit Function
Hdl_ERROR:
SetMaxCountTocodeFormat = False
End Function
|