|
データの量が多い場合に1行づつ削除では遅いので
先に、隣の列に削除Flagを立てて、それをKeyにソートし
下の行に削除する行を集めて一気に削除します
Option Explicit
Public Sub PigeonholeData()
' データ整理
'データ列数(A列のみ)
Const clngColumns As Long = 1
'Keyと成る列を指定(基準セル位置からの列Offsetで指定:基準がA列なので0)
Const clngKeys As Long = 0
Dim rngList1 As Range
Dim lngColumns1 As Long
Dim rngList2 As Range
Dim lngColumns2 As Long
Dim strComments As String
Dim strProm As String
'前月Listの先頭セル位置を基準とする(List先頭の見出しセル位置)
Set rngList1 = ActiveSheet.Range("A1")
'Listの列数(A列〜K列)
lngColumns1 = 11
'当月Listの先頭セル位置を基準とする(List先頭の見出しセル位置)
Set rngList2 = ActiveSheet.Range("M1")
'Listの列数(M列〜W列)
lngColumns2 = 11
'画面更新を停止
Application.ScreenUpdating = False
'前月Listの整理
strComments = RowsDelete(rngList1, lngColumns1, 7, 3)
strProm = "前月Listの " & strComments
'当月Listの整理
strComments = RowsDelete(rngList2, lngColumns2, 7, 3)
strProm = strProm & vbCrLf & "当月Listの " & strComments
'突き合わせ処理
' strComments = DataMatch(rngList1, lngColumns1, rngList2, lngColumns2)
' strProm = strProm & vbCrLf & strComments
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList1 = Nothing
MsgBox strProm, vbInformation
End Sub
' Listから指定条件のレコード削除
'
' rngList:List先頭セル位置(見出し位置)
' lngColumns:Listの列数
' lngKey1:「受注金額」の列位置、rngListで指定した列位置を0列とした列Offsetで指定
' lngKey2:「物件名」の列位置、rngListで指定した列位置を0列とした列Offsetで指定
'
' 戻り値:処理コメント
'
Private Function RowsDelete(rngList As Range, _
lngColumns As Long, _
lngKey1 As Long, _
lngKey2 As Long) As String
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim vntKeys1() As Variant
Dim vntKeys2() As Variant
Dim lngDelete() As Long
Dim lngCount As Long
Dim vntDelList As Variant
'「物件名」の削除条件を列挙(ウィルドカード使用可)
'完全一致:"AAAA"、含む:"*AAAA*"
'前方一致:"AAAA*"、後方一致:"*AAAA" ※「Like演算子」のHelp参照
vntDelList = Array("AAA", "BBB*", "CCCC*", "*DDDDD*")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, lngKey2).End(xlUp).Row - .Row
If lngRows <= 0 Then
RowsDelete = "データが有りません"
Exit Function
End If
'「受注金額」データを配列に取得
vntKeys1 = .Offset(1, lngKey1).Resize(lngRows + 1).Value
'「物件名」データを配列に取得
vntKeys2 = .Offset(1, lngKey2).Resize(lngRows + 1).Value
'削除Flag用の配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
End With
'List先頭〜最終まで繰り返し
For i = 1 To lngRows
'「受注金額」が0なら
If vntKeys1(i, 1) = 0 Then
'削除Flagを立てる
lngDelete(i, 1) = 1
'削除数をカウント
lngCount = lngCount + 1
End If
'削除Flagが立っていないなら
If Not lngDelete(i, 1) Then
For j = 0 To UBound(vntDelList)
If vntKeys2(i, 1) Like vntDelList(j) Then
'削除Flagを立てる
lngDelete(i, 1) = 1
'削除数をカウント
lngCount = lngCount + 1
End If
Next j
End If
Next i
With rngList
'削除行が有るなら
If lngCount > 0 Then
'最終列の後ろに列挿入
.Offset(1, lngColumns).EntireColumn.Insert
'Flagを最終列に出力
.Offset(1, lngColumns).Resize(lngRows) = lngDelete
'空白行を最終行に集める為、L列をKeyとして整列
.Offset(1).Resize(lngRows, lngColumns + 1).Sort _
Key1:=.Offset(, lngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'削除行を削除
.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp
'削除Flag列を削除
.Offset(, lngColumns).EntireColumn.Delete
End If
End With
RowsDelete = lngCount & "件の削除処理が行われました"
End Function
|
|