| |
Sheet1にデータが有るとして、列見出しが有る物とします
データは、A列〜C列の3列とします
結果は、Sheet2に出力に出力される物とします
実行時にA列昇順のB列昇順で整列され、終了直前に元の行位置に再整列されます
以下を標準モジュールに記述して下さい
Option Explicit
Public Sub Sample()
'元々のデータ列数（A列〜C列）
Const clngColumns As Long = 3
Dim i As Long
Dim j As Long
Dim k As Long '★２重登録をスッキップ時に使用
Dim lngRows As Long
Dim lngTop As Long
Dim lngCount As Long
Dim lngMember() As Long
Dim vntMember As Variant
Dim lngMemberMax As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntResult As Variant
Dim lngWrite As Long
Dim vntGroup As Variant
Dim strProm As String
'画面更新を停止
Application.ScreenUpdating = False
'Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'出力Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
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
'データをA列昇順のB列昇順で整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1), Order1:=xlAscending, _
Key2:=.Offset(1, 1), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'Key(A列〜B列)データを配列に取得
vntGroup = .Offset(1).Resize(lngRows + 1, 2).Value
End With
'園児数をカウントする配列を確保
ReDim lngMember(1 To lngRows, 1 To 1)
'出力行位置の初期値
lngWrite = 1
'先頭値の位置を記録
lngTop = 1
'同一グループ(保護者+住所)データ行数のカウント初期値
lngCount = 1
For i = 2 To lngRows + 1
'注目行と現在行の値が(保護者+住所)違った場合
If vntGroup(lngTop, 1) <> vntGroup(i, 1) _
Or vntGroup(lngTop, 2) <> vntGroup(i, 2) Then
'同一グループの園児名を配列に取得
vntMember = rngList.Offset(lngTop, 2) _
.Resize(lngCount + 1).Value
'園児数をカウント
lngMember(lngWrite, 1) = lngCount
'結果出力用配列を確保(保護者+住所+園児名1+園児名2・・)
ReDim vntResult(1 To 2 + lngCount)
'結果出力用配列に保護者、住所を転記
vntResult(1) = vntGroup(lngTop, 1)
vntResult(2) = vntGroup(lngTop, 2)
'★サンプルデータでは、同一の保護者に同名の園児が
'２人居る事に成ってますが？
'データの２重登録をスッキップする場合、以下◎印を★印の様に
'-----------------------------------------------------------------
'結果出力用配列に園児を転記
For j = 1 To lngCount '◎
vntResult(2 + j) = vntMember(j, 1) '◎
Next j '◎
'園児数をカウント
lngMember(lngWrite, 1) = lngCount '◎
'園児数最大値を保存
If lngMemberMax < lngCount Then '◎
lngMemberMax = lngCount '◎
End If '◎
'-----------------------------------------------------------------
' '結果出力用配列に園児を転記
' k = 0 '★
' For j = 1 To lngCount '★
' If vntResult(2 + k) <> vntMember(j, 1) Then '★
' k = k + 1 '★
' vntResult(2 + k) = vntMember(j, 1) '★
' End If '★
' Next j '★
' '園児数をカウント
' lngMember(lngWrite, 1) = k '★
' '園児数最大値を保存
' If lngMemberMax < k Then '★
' lngMemberMax = k '★
' End If '★
'-----------------------------------------------------------------
'結果データを出力
rngResult.Offset(lngWrite).Resize(, _
2 + lngCount).Value = vntResult
'出力行位置を更新
lngWrite = lngWrite + 1
'注目行の位置を記録
lngTop = i
'同一グループ(保護者+住所)データ行数のカウント初期値に
lngCount = 1
Else
'同一グループ(保護者+住所)データ行数のカウントを更新
lngCount = lngCount + 1
End If
Next i
With rngResult
'園児数を出力
.Offset(1, 2 + lngMemberMax) _
.Resize(lngWrite - 1).Value = lngMember
'結果シートに列見出しを出力
rngList.Resize(, 2).Copy Destination:=rngResult
ReDim vntResult(1 To lngMemberMax + 1)
For i = 1 To lngMemberMax
vntResult(i) = "園児名"
Next i
vntResult(lngMemberMax + 1) = "園児数"
.Offset(, 2).Resize(, lngMemberMax + 1).Value = vntResult
End With
With rngList
'元データを復帰
.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(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 07/1/14(日) 8:41 -
