Excel VBA質問箱 IV

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

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


18094 / 76738 ←次へ | 前へ→

【64088】Re:ご協力お願いします。
発言  初心者  - 10/1/17(日) 23:30 -

引用なし
パスワード
   頂いたコードに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して見て下さい
>それを確認して見ます

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 発言

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