| |
データの量が多い場合に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
|
|
Hirofumi
- 10/1/15(金) 13:05 -
