Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


18093 / 76738 ←次へ | 前へ→

【64089】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/18(月) 7:04 -

引用なし
パスワード
   コードの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
0 hits

【64046】ご協力お願いします。 初心者 10/1/12(火) 22:19 質問
【64047】Re:ご協力お願いします。 Hirofumi 10/1/12(火) 23:49 回答
【64048】Re:ご協力お願いします。 Hirofumi 10/1/13(水) 0:22 回答
【64052】Re:ご協力お願いします。 初心者 10/1/13(水) 16:57 質問
【64053】Re:ご協力お願いします。 Hirofumi 10/1/13(水) 19:05 回答
【64054】Re:ご協力お願いします。 初心者 10/1/13(水) 20:38 お礼
【64055】Re:ご協力お願いします。 ご参考 10/1/13(水) 23:13 発言
【64060】Re:ご協力お願いします。 Hirofumi 10/1/14(木) 12:25 回答
【64065】Re:ご協力お願いします。 初心者 10/1/14(木) 22:41 質問
【64066】Re:ご協力お願いします。 Hirofumi 10/1/14(木) 23:37 発言
【64067】Re:ご協力お願いします。 初心者 10/1/15(金) 8:52 発言
【64068】Re:ご協力お願いします。 Hirofumi 10/1/15(金) 13:05 発言
【64069】Re:ご協力お願いします。 Hirofumi 10/1/15(金) 13:13 発言
【64074】Re:ご協力お願いします。 初心者 10/1/16(土) 22:29 質問
【64075】Re:ご協力お願いします。 かみちゃん 10/1/16(土) 22:34 発言
【64076】Re:ご協力お願いします。 Hirofumi 10/1/16(土) 23:15 回答
【64077】Re:ご協力お願いします。 Hirofumi 10/1/16(土) 23:27 回答
【64078】Re:ご協力お願いします。 Hirofumi 10/1/16(土) 23:45 回答
【64079】Re:ご協力お願いします。 初心者 10/1/17(日) 1:01 発言
【64080】Re:ご協力お願いします。 Hirofumi 10/1/17(日) 8:56 回答
【64081】Re:ご協力お願いします。 Hirofumi 10/1/17(日) 9:47 回答
【64085】Re:ご協力お願いします。 初心者 10/1/17(日) 12:41 発言
【64086】Re:ご協力お願いします。 Hirofumi 10/1/17(日) 16:10 回答
【64088】Re:ご協力お願いします。 初心者 10/1/17(日) 23:30 発言
【64089】Re:ご協力お願いします。 Hirofumi 10/1/18(月) 7:04 回答
【64090】Re:ご協力お願いします。 Hirofumi 10/1/18(月) 7:16 発言
【64102】Re:ご協力お願いします。 初心者 10/1/19(火) 9:26 お礼
【64082】Re:ご協力お願いします。 かみちゃん 10/1/17(日) 10:01 発言

18093 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free