| |
一覧表というｼｰﾄ（Sheet1）に下記のﾃﾞｰﾀを貼り付けてました。
これをｼｰﾄﾓｼﾞｭｰﾙと言うんですかね?
詳しくないのですいません・・・
Option Explicit
Public Sub Sample_1()
'元々のデータ列数（A列〜BM列）
Const clngColumns As Long = 65
'グループの有る列(B列のA列からの列Offset)
Const clngGroup As Long = 1
'結果出力の先頭位置
Const cstrTop As String = "A7"
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 vntGroup As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = Worksheets("一覧表").Range("A7")
'画面更新を停止
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を作成
With .Offset(1, clngColumns)
.Value = 1
.Resize(lngRows).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False
End With
'データをA列で整列
DataSort .Offset(1).Resize(lngRows, clngColumns + 1), .Offset(, clngGroup)
'A列データを配列に取得
vntGroup = .Offset(1, clngGroup).Resize(lngRows + 1).Value
End With
'仮に結果と元表を同じにして置く
Set rngResult = rngList
'注目値の位置を記録
lngTop = 1
'データ行数のカウント初期値
lngCount = 1
For i = 2 To lngRows + 1
'注目値と現在値が違った場合
If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
'シート名の存在確認をして、無い場合追加し在る場合はデータ消去
GetSheets "依頼職場_" & vntGroup(lngTop, 1), cstrTop, rngResult
With rngList
'列見出しを転記
' .Offset(, 2).Resize(, clngColumns).Copy Destination:=rngResult
'データを転記
.Offset(lngTop, 2).Resize(lngCount, clngColumns).Copy _
Destination:=rngResult.Offset(1)
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
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngSortOrder As Long = xlAscending, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=lngSortOrder, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
Private Sub GetSheets(vntName As Variant, strTop As String, rngResult As Range)
Dim i As Long
Dim lngRows As Long
Dim wksMark As Worksheet
'シートの存在確認
For Each wksMark In Worksheets
If StrComp(wksMark.Name, vntName, vbTextCompare) = 0 Then
Exit For
End If
Next wksMark
'もし、シートが無いなら
If wksMark Is Nothing Then
'シートを追加して、シート名を設定
Set wksMark = Worksheets.Add(After:=rngResult.Parent)
wksMark.Name = vntName
Else
'データを消去
wksMark.UsedRange.ClearComments
End If
Set rngResult = wksMark.Range(strTop)
Set wksMark = Nothing
End Sub
|
|
AAA
- 10/3/31(水) 16:33 -
