SQL とソート (既に提供済み) 以外の別のアプローチを使用しました。
このコードをテストしましたが、動作します。
このコードの背後にある一般的な考え方:
- クラスモジュール「clsSheet」には、シートごとにすべての情報が含まれています。列ヘッダー A、B、C だけでなく、使用される範囲、この範囲が読み込まれる配列、および最大の行/列も含まれます。
- これらの自己作成データ オブジェクトはコレクションにロードされ、その後、コードの次の部分がメモリ内のすべてのコードを (高速に) 実行します。
- ディクショナリが作成され、「モジュール名」(つまり、module1、2、3 など) がキーとして含まれ、clsModule オブジェクトが値として含まれます。キー (つまりモジュール名) がまだ存在しない場合は、新しい項目が追加されます。
- clsModule クラスは、各モジュール名に関する情報を保持します。列 A、B、C の情報。情報は配列の形式で格納されます。
- すべての情報がディクショナリに格納されている場合は、ディクショナリのコンテンツを適切な形式に変換するだけです。この場合、各シートに辞書キーの名前を付け、対応するシートにデータをロードすることにしました。
このコードには以下が含まれます。
- 「A」、「B」、「C」という名前のヘッダーを動的に見つけて、バグのリスクを軽減します。
- 高速実行;
- 新しいワークブックを作成し、各「モジュール」の値を別のシートに書き込みます。
- これらのクラスは、最小限の変更で他の状況でも再利用できます。
このアプローチの主な利点は柔軟性です。すべてのデータをフレームワークにロードするため、クラスを設定してそれらのプロパティを呼び出すことにより、後で任意のアクションを仮想的に実行できます。
Sub GetModules()
Dim cSheet As clsSheet
Dim cModule As clsModule
Dim oSheet As Excel.Worksheet
Dim oColl_Sheets As Collection
Dim oDict As Object
Dim vTemp_Array_A As Variant
Dim vTemp_Array_B As Variant
Dim vTemp_Array_C As Variant
Dim lCol_A As Long
Dim lCol_B As Long
Dim lCol_C As Long
Dim lMax_Row As Long
Dim lMax_Col As Long
Dim oRange As Range
Dim oRange_A As Range
Dim oRange_B As Range
Dim oRange_C As Range
Dim vArray As Variant
Dim lCnt As Long
Dim lCnt_Modules As Long
Dim oBook As Excel.Workbook
Dim oSheet_Results As Excel.Worksheet
Set oColl_Sheets = New Collection
Set oDict = CreateObject("Scripting.Dictionary")
'Get number of columns, rows and headers A, B, C dynamically
'This is useful in case columns are inserted
For Each oSheet In ThisWorkbook.Sheets
Set cSheet = New clsSheet
Set cSheet = cSheet.get_Sheet_Data(cSheet, oSheet)
oColl_Sheets.Add cSheet
Next oSheet
'At this point, your entire sheet data structure is already contained in the collection oColl_Sheets
Set cSheet = Nothing
'Loop through the sheet objects and retrieve the values into modules
For Each cSheet In oColl_Sheets
'Now you load back all data from the sheet and perform loops in memory through the arrays
lCol_A = cSheet.fA_Col
lCol_B = cSheet.fB_Col
lCol_C = cSheet.fC_Col
lMax_Row = cSheet.fMax_Row
lMax_Col = cSheet.fMax_Col
Set oRange = cSheet.fRange
vArray = cSheet.fArray
For lCnt = 1 To lMax_Row - 1
'Check if the module already exists
If Not oDict.Exists(vArray(1 + lCnt, 1)) Then '+1 due to header
lCnt_Modules = lCnt_Modules + 1
Set cModule = New clsModule
'Add to dictionary when new module (thus key) is new
Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), True)
Set cModule = cModule.Add_To_Array_B(cModule, lCol_B, vArray(1 + lCnt, lCol_B), True)
Set cModule = cModule.Add_To_Array_C(cModule, lCol_C, vArray(1 + lCnt, lCol_C), True)
oDict.Add vArray(1 + lCnt, 1), cModule
Else
Set cModule = oDict(vArray(1 + lCnt, 1))
'Replace when module (thus key) already exists
Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), False)
Set cModule = cModule.Add_To_Array_B(cModule, lCol_A, vArray(1 + lCnt, lCol_B), False)
Set cModule = cModule.Add_To_Array_C(cModule, lCol_A, vArray(1 + lCnt, lCol_C), False)
Set oDict(vArray(1 + lCnt, 1)) = cModule
End If
Next lCnt
Next cSheet
'Now you have all the data available in your dictionary: per module (key), there is an array with the data you need.
'The only thing you have to do is open a new workbook and paste the data there.
'Below an example how you can paste the results per worksheet
Set oBook = Workbooks.Add
Set oSheet_Results = oBook.Sheets(1)
lCnt = 0
For lCnt = 0 To oDict.Count - 1
'Fill in values from dictionary
oBook.Sheets.Add().Name = oDict.Keys()(lCnt)
ReDim vTemp_Array_A(1 To UBound(oDict.Items()(lCnt).fA_Arr))
ReDim vTemp_Array_B(1 To UBound(oDict.Items()(lCnt).fB_Arr))
ReDim vTemp_Array_C(1 To UBound(oDict.Items()(lCnt).fC_Arr))
oBook.Sheets(oDict.Keys()(lCnt)).Range("A1").Value = "A"
oBook.Sheets(oDict.Keys()(lCnt)).Range("B1").Value = "B"
oBook.Sheets(oDict.Keys()(lCnt)).Range("C1").Value = "C"
vTemp_Array_A = oDict.Items()(lCnt).fA_Arr
vTemp_Array_B = oDict.Items()(lCnt).fB_Arr
vTemp_Array_C = oDict.Items()(lCnt).fC_Arr
Set oRange_A = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 1), Cells(1 + UBound(vTemp_Array_A), 1))
Set oRange_B = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 2), Cells(1 + UBound(vTemp_Array_B), 2))
Set oRange_C = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 3), Cells(1 + UBound(vTemp_Array_C), 3))
oRange_A = Application.Transpose(vTemp_Array_A)
oRange_B = Application.Transpose(vTemp_Array_B)
oRange_C = Application.Transpose(vTemp_Array_C)
Next lCnt
Set oColl_Sheets = Nothing
Set oRange = Nothing
Set oDict = Nothing
End Sub
「clsModule」というクラスモジュール
Option Explicit
Private pModule_Nr As Long
Private pA_Arr As Variant
Private pB_Arr As Variant
Private pC_Arr As Variant
Public Function Add_To_Array_A(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule
Dim vArray As Variant
vArray = cModule.fA_Arr
If bNew Then
ReDim vArray(1 To 1)
vArray(1) = vValue
Else
ReDim Preserve vArray(1 To UBound(vArray) + 1)
vArray(UBound(vArray)) = vValue
End If
cModule.fA_Arr = vArray
Set Add_To_Array_A = cModule
End Function
Public Function Add_To_Array_B(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule
Dim vArray As Variant
vArray = cModule.fB_Arr
If bNew Then
ReDim vArray(1 To 1)
vArray(1) = vValue
Else
ReDim Preserve vArray(1 To UBound(vArray) + 1)
vArray(UBound(vArray)) = vValue
End If
cModule.fB_Arr = vArray
Set Add_To_Array_B = cModule
End Function
Public Function Add_To_Array_C(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule
Dim vArray As Variant
vArray = cModule.fC_Arr
If bNew Then
ReDim vArray(1 To 1)
vArray(1) = vValue
Else
ReDim Preserve vArray(1 To UBound(vArray) + 1)
vArray(UBound(vArray)) = vValue
End If
cModule.fC_Arr = vArray
Set Add_To_Array_C = cModule
End Function
Property Get fModule_Nr() As Long
fModule_Nr = pModule_Nr
End Property
Property Let fModule_Nr(lModule_Nr As Long)
pModule_Nr = lModule_Nr
End Property
Property Get fA_Arr() As Variant
fA_Arr = pA_Arr
End Property
Property Let fA_Arr(vA_Arr As Variant)
pA_Arr = vA_Arr
End Property
Property Get fB_Arr() As Variant
fB_Arr = pB_Arr
End Property
Property Let fB_Arr(vB_Arr As Variant)
pB_Arr = vB_Arr
End Property
Property Get fC_Arr() As Variant
fC_Arr = pC_Arr
End Property
Property Let fC_Arr(vC_Arr As Variant)
pC_Arr = vC_Arr
End Property
「clsSheet」というクラスモジュール
Option Explicit
Private pMax_Col As Long
Private pMax_Row As Long
Private pArray As Variant
Private pRange As Range
Private pA_Col As Long
Private pB_Col As Long
Private pC_Col As Long
Public Function get_Sheet_Data(cSheet As clsSheet, oSheet As Excel.Worksheet) As clsSheet
Dim oUsed_Range As Range
Dim lLast_Col As Long
Dim lLast_Row As Long
Dim iCnt As Integer
Dim vArray As Variant
Dim lNr_Rows As Long
Dim lNr_Cols As Long
Dim lCnt As Long
With oSheet
lLast_Row = .Cells(.Rows.Count, "A").End(xlUp).Row
lLast_Col = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
oSheet.Activate
Set oUsed_Range = oSheet.Range(Cells(1, 1), Cells(lLast_Row, lLast_Col))
cSheet.fRange = oUsed_Range
lNr_Rows = oUsed_Range.Rows.Count
cSheet.fMax_Row = lNr_Rows
lNr_Cols = oUsed_Range.Columns.Count
cSheet.fMax_Col = lNr_Cols
ReDim vArray(1 To lNr_Rows, 1 To lNr_Cols)
vArray = oUsed_Range
cSheet.fArray = vArray
For lCnt = 1 To lNr_Cols
Select Case vArray(1, lCnt)
Case "A"
cSheet.fA_Col = lCnt
Case "B"
cSheet.fB_Col = lCnt
Case "C"
cSheet.fC_Col = lCnt
End Select
Next lCnt
Set get_Sheet_Data = cSheet
End Function
Property Get fMax_Col() As Long
fMax_Col = pMax_Col
End Property
Property Let fMax_Col(lMax_Col As Long)
pMax_Col = lMax_Col
End Property
Property Get fMax_Row() As Long
fMax_Row = pMax_Row
End Property
Property Let fMax_Row(lMax_Row As Long)
pMax_Row = lMax_Row
End Property
Property Get fRange() As Range
Set fRange = pRange
End Property
Property Let fRange(oRange As Range)
Set pRange = oRange
End Property
Property Get fArray() As Variant
fArray = pArray
End Property
Property Let fArray(vArray As Variant)
pArray = vArray
End Property
Property Get fA_Col() As Long
fA_Col = pA_Col
End Property
Property Let fA_Col(lA_Col As Long)
pA_Col = lA_Col
End Property
Property Get fB_Col() As Long
fB_Col = pB_Col
End Property
Property Let fB_Col(lB_Col As Long)
pB_Col = lB_Col
End Property
Property Get fC_Col() As Long
fC_Col = pC_Col
End Property
Property Let fC_Col(lC_Col As Long)
pC_Col = lC_Col
End Property