| |
Sheet1には、列見出しが有る物とします
Keyと成るA列の処理月はシリアル値とします
データは、A列〜L列の12列とし､転記するグループは､A列に有るとします
実行時にA列で整列され終了直前に元の行位置に再整列されます
Option Explicit
Public Sub Sample()
'元々のデータ列数（A列〜L列）
Const clngColumns As Long = 12
'グループの有る列(A列のA列からの列Offset)
Const clngGroup As Long = 0
'結果出力の先頭位置
Const cstrTop As String = "A1"
Dim i As Long
Dim lngRows 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 strProm As String
'画面更新を停止
Application.ScreenUpdating = False
'Listの先頭セル位置を基準とする（A列の列見出し「処理月」のセル位置）
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データをA列で整列
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(, clngGroup), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'A列データを配列に取得
vntGroup = .Offset(1, clngGroup).Resize(lngRows + 1).Value
'列見出し範囲を取得
Set rngHeader = .Resize(, clngColumns)
End With
'仮に結果と元表を同じにして置く
Set rngResult = rngList
'注目値の位置を記録
lngTop = 1
'データ行数のカウント初期値
lngCount = 1
For i = 2 To lngRows + 1
'注目値と現在値が違った場合
If Month(vntGroup(lngTop, 1)) <> Month(vntGroup(i, 1)) Then
'出力シートを設定
GetSheets Format(vntGroup(lngTop, 1), "m月"), cstrTop, _
rngResult, rngHeader
'データを転記
rngList.Offset(lngTop).Resize(lngCount, clngColumns).Copy _
Destination:=rngResult
'注目値の位置を記録
lngTop = i
'データ行数のカウント初期値に
lngCount = 1
Else
'データ行数のカウントを更新
lngCount = lngCount + 1
End If
Next i
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)
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)
wksMark.Name = strName
End If
'転記先のシートにデータを追加して行く場合
' With wksMark.Range(strTop)
' '行数の取得
' lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
' If lngRows <= 0 Then
' '列見出しを出力
' rngHeader.Copy Destination:=.Cells(1, 1)
' '出力位置を設定
' Set rngResult = .Offset(1)
' Else
' '出力位置を設定
' Set rngResult = .Offset(lngRows + 1)
' End If
' End With
'転記先のシートを全てクリアして転記する場合
With wksMark
'データを消去
.UsedRange.ClearContents
'列見出しを出力
rngHeader.Copy Destination:=.Range(strTop)
'出力位置を設定
Set rngResult = .Range(strTop).Offset(1)
End With
Set wksMark = Nothing
End Sub
|
|
Hirofumi
- 10/10/6(水) 9:19 -
