| |
コードのUpありがとうございました
ごめんなさい、原因が解りました
「Function RowsDelete」の中で
'削除Flagが立っていないなら
If Not lngDelete(i, 1) Then
「受注金額」が0だった場合、「物件名」の条件判断をスキップしているケ所が有ります
(「受注金額」が0だったら削除が決定なので、もう一度、削除の判断をさせない)
この時のコードが、勘違いでLong型の変数なのに、Bool型の比較を行っているのが原因でした
因って以下の様に修正します
'削除Flagが立っていないなら
If lngDelete(i, 1) = 0 Then '★変更
一応、以下に修正して、全文をUpして置きます
尚、先頭部の※印の4行は削除して下さい
Option Explicit
Public Sub 不要行削除()
' データ整理
'※以下4行削除して下さい(※印)
' 'データ列数（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 lngDelete(i, 1) = 0 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
- 10/1/18(月) 7:04 -
