| |
頂いたコードにExit forを追加したコードになります。
Option Explicit
Public Sub 不要行削除()
' データ整理
'データ列数（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("*サマリ*", "*保守*")
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
'Forを抜ける
Exit For '★追加
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 さん：
>▼初心者 さん：
>>Hirofumiさん
>>
>>コメント有難う御座いました。
>>
>>また、詳細なエラー内容をお伝えできておらずすみません。
>>
>>>もう一度、削除List
>>>
>>> vntDelList = Array("*保守*", "*サマリ*")
>>>
>>>を、元にもどしてTestして下さい
>>>そして、エラーが出たら、ダイアログの文章をUpして下さい
>>>
>>エラーは
>>
>>'実行時エラー1004'
>>アプリケーション定義またはオブジェクト定義のエラーです。
>>
>>が出ました。
>>
>>
>>>次に、ダイアログの「デバグ」を押して下さい
>>>すると、エラー行が反転表示されますので
>>>lngColumns、lngCount、lngRowsの各変数にマウスポインタを持って行って変数の値をUpして下さい
>>
>>lngColumns=11
>>lngCount=4570
>>lngRows=4357
>>
>>です。
>>
>>
>>>
>>>次に、マクロを終了してExcelの画面に戻って下さい
>>>各Listの最終列を見て下さい、其処に0か1が出力されています
>>>（この0の行は残す行で1の行が削除されるぎょうです）
>>>正常なら、Listの上に0が集まり、1が下に集まっていますので確認して下さい
>>
>>L列に0と1の数値が入っています。
>>上に0、下に1が入っている状態で止まっています。
>>
>>右の今月データんは0,1は入っていません。
>>
>>このような回答でよろしいでしょうか？
>
>ありがとうございます
>此れは、他の要因が有るのかも解りませんが？
>典型的に「Exit For」が無い状態だと思います
>多分、「Exit For」の追加位置が違っている様な気がします
>因って今、初心者さんが動かしているコードの「行削除処理」の全文をUpして見て下さい
>それを確認して見ます
|
|
初心者
- 10/1/17(日) 23:30 -
