Excel VBA質問箱 IV

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

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


3125 / 13644 ツリー ←次へ | 前へ→

【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 発言[未読]

【64046】ご協力お願いします。
質問  初心者 E-MAIL  - 10/1/12(火) 22:19 -

引用なし
パスワード
   みなさんこんにちわ。

何とか自力でと色々なサイトを参考にしてみたのですが、どうしても分からないので質問させて頂きたいと思います。
以下のデータをご覧ください。

<データ>
No    アドレス    名前    所持金    更新        No    アドレス    名前    所持金    更新
1    aaa@com    suzuki    100            1    fff@com    yamamoto    1000    
2    bbb@com    tanaka    500            2    bbb@com    tanaka    500    
3    ccc@com    yamada    300            3    ccc@com    yamada    300    
4    ddd@com    watanabe    400            4    ddd@com    watanabe    400    
                        5    yyy@com    sato    800    
※改行で分かりにくければ申し訳ありません。

左側のエリアが前月、右側のエリアが今月のデータとします。
前月と今月のデータを比較し、その差分を確認するマクロを作りたいと考えています。

<条件>
1.比較する列は「アドレス」、「名前」、「所持金」
2.3項目が合致した場合は「更新」列は空欄のまま
3.左の表にあるが、右の表にないものは左の表の「更新」列に「削除」の文字をセット
4.右の表に新規で追加されたものは右の表の「更新」列に「追加」の文字をセット
5.「アドレス」、「名前」は合致するが「所持金」に差異があった場合、「更新」列に「金額変更」の文字をセットし、その右のセルに差異金額をセット

分かりにくければ申し訳ありません。

皆さま、何卒よろしくお願いします。

【64047】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/12(火) 23:49 -

引用なし
パスワード
   こんなかな?

前月のデータ同一シート内で、A列&B列の値の重複が無い物とします
今月のデータ同一シート内で、A列&B列の値の重複が有る物とします
前月のデータはA列〜F列、今月のデータはG列〜L列とします
各表の1行目は列見出し、2行目よりデータとします

Option Explicit
'Option Compare Text

Public Sub DataMatch()

  '前月のデータ列数(A列〜F列)
  Const clngColumns1 As Long = 6
  '所持金の列位置を指定(基準セルからの列Offset)
  Const clngItems1 As Long = 3
  
  '今月のデータ列数(G列〜L列)
  Const clngColumns2 As Long = 6
  '所持金の列位置を指定(基準セルからの列Offset)
  Const clngItems2 As Long = 3
  
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim vntResult1 As Variant
  
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim vntResult2 As Variant
  Dim lngMatch As Long
   
  Dim strProm As String

  '前月データシートのA1を基準とします
  Set rngList1 = ActiveSheet.Range("A1")
  
  '今月データシートのA1を基準とする
  Set rngList2 = ActiveSheet.Range("G1")
  
  '前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(1, 2)
  '今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(1, 2)
  
  '前月の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  '今月の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '前月の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult1(1 To lngRows1, 1 To 2)
  End If
  
  '今月基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult2(1 To lngRows2, 1 To 2)
  End If
  
  '前月のシートの比較位置
  lngComp1 = 1
  '今月のシートの比較位置
  lngComp2 = 1
  '前月のシート若しくは、今月のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        '所持金を比較
        vntResult1(lngComp1, 1) = rngList1.Offset(lngComp1, clngItems1).Value
        vntResult2(lngComp2, 1) = rngList2.Offset(lngComp2, clngItems2).Value
        If vntResult1(lngComp1, 1) <> vntResult2(lngComp2, 1) Then
          vntResult1(lngComp1, 2) _
              = vntResult2(lngComp2, 1) - vntResult1(lngComp1, 1)
          vntResult2(lngComp2, 2) _
              = vntResult2(lngComp2, 1) - vntResult1(lngComp1, 1)
          vntResult1(lngComp1, 1) = "金額変更"
          vntResult2(lngComp2, 1) = "金額変更"
        Else
          vntResult1(lngComp1, 1) = Empty
          vntResult2(lngComp2, 1) = Empty
        End If
        '前月、今月のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        lngComp2 = lngComp2 + 1
      Case Is = -1 '前月の固有値の場合
        vntResult1(lngComp1, 1) = "削除"
        '前月のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 '今月の固有値の場合
        vntResult2(lngComp2, 1) = "追加"
        '今月のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  '結果を出力
  rngList1.Offset(1, clngItems1 + 1).Resize(lngRows1, 2) = vntResult1
  rngList2.Offset(1, clngItems2 + 1).Resize(lngRows2, 2) = vntResult2
  
  '前月のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  '今月のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                vntKeys As Variant, _
                vntData As Variant) As Boolean

  Dim i As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    'データをvntKeys1列で整列
    For i = UBound(vntKeys) To 0 Step -1
      DataSort .Offset(1).Resize(lngRows, lngColumns), .Offset(1, vntKeys(i))
    Next i
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function

Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)

  With rngList
    '元データ順位を復帰
    DataSort .Offset(1).Resize(lngRows, lngColumns), .Offset(1)
  End With

End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
            vntKeys2 As Variant, lngPos2 As Long) As Long

'  データの大小比較

  Dim i As Long
  Dim lngMax As Long
  
  If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
    DataCompare = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
    DataCompare = -1
    Exit Function
  End If
    
  lngMax = UBound(vntKeys1, 1)
  
  For i = 0 To lngMax
    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
      Exit For
    End If
  Next i
  
  If i > lngMax Then
    DataCompare = 0
  Else
    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
      DataCompare = -1
    Else
      DataCompare = 1
    End If
  End If
  
End Function

【64048】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/13(水) 0:22 -

引用なし
パスワード
   書き忘れましたが?
Keyと成る、B列、C列
詰まり、アドレス、名前に全角が含まれる場合は、コメントアウトして有る

'Option Compare Text

を活かして下さい
さもないと、突き合わせが上手く行きません
ただ、全角無いならコメントアウトのままにして下さい
活かした場合より2〜3割速く成ると思います

【64052】Re:ご協力お願いします。
質問  初心者 E-MAIL  - 10/1/13(水) 16:57 -

引用なし
パスワード
   早速のご連絡有難うございました。
正直、感動しました。。

お送りしたのはサンプルなのですが、実際には以下のようなシートとなります。

<前月シートの列名>
担当者名    顧客名    物件名    計上年月    受注予算化    受注ランク    受注額    受注台数    前月差異    差異金額

※A〜K列

<今月シートの列名>
担当課名    担当者名    顧客名    物件名    計上年月    受注予算化    受注ランク    受注額    受注台数    今月差異    差異金額

※M〜W列

このうち、比較するのは「顧客名」「物件名」「受注額」です。
1.「顧客名」「物件名」「受注額」が合致したものは「前月差異」「今月差異」は空欄
2.前月シートの「顧客名」「物件名」まで比較し今月シートに該当しないものは「前月差異」に「削除」をセット
3.今月シートに新規で追加された行は「今月差異」に「追加」をセット
4.「顧客名」「物件名」までは合致するが、「受注額」に差異がある場合、「差異金額」に差額をセット
※前月より今月が多ければプラス表示、少なければマイナス表示

行タイトルである「受注額」は別シートで「売上額」「入金額」等の名称に変更となるが、データの中身は変わりません。

再度ご検討いただけませんでしょうか?

【64053】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/13(水) 19:05 -

引用なし
パスワード
   基本的にコードを変えてません
変更した所は、
各パラメタ(Constで定義されている定数と比較Keyの位置)
定数項目2個追加(差異列の位置、前回は受注額の後ろとしていた物を独立に)
変数を2個追加(差異計算用)
データ復帰に使うKey列を作業列として、L列とX列を使用(前回は先頭No列)

尚、前月Listの先頭に「担当課名」が有りませんが善いのですね?
 「※A〜K列」と成っているのにレスでは「A〜J列」しか有りませんが?
 もし先頭列に「担当課名」が在るようなら、「★???」行を活かして下の行を削除して下さい

Option Explicit
Option Compare Text

Public Sub DataMatch_2()

  '前月のデータ列数(A列〜K列)
  Const clngColumns1 As Long = 11
  '受注額の列位置を指定(基準セルからの列Offset)
'  Const clngItems1 As Long = 7 '★???
  Const clngItems1 As Long = 6
  '差異の列位置を指定(基準セルからの列Offset)
'  Const clngDiffer1 As Long = 9 '★???
  Const clngDiffer1 As Long = 8
  
  '今月のデータ列数(M列〜W列)
  Const clngColumns2 As Long = 11
  '受注額の列位置を指定(基準セルからの列Offset)
  Const clngItems2 As Long = 7
  '差異の列位置を指定(基準セルからの列Offset)
  Const clngDiffer2 As Long = 9
  
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim vntResult1 As Variant
  Dim vntTmp1 As Variant
  
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim vntResult2 As Variant
  Dim vntTmp2 As Variant
  
  Dim lngMatch As Long
  Dim strProm As String

  '前月データシートのA1を基準とします
  Set rngList1 = ActiveSheet.Range("A1")
  
  '今月データシートのA1を基準とする
  Set rngList2 = ActiveSheet.Range("M1")
  
  '前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
'  vntKeys1 = Array(2, 3) '★???
  vntKeys1 = Array(1, 2)
  '今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'M列=0、O列=2、Q列=4
  vntKeys2 = Array(2, 3)
  
  '前月の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  '今月の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '前月の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult1(1 To lngRows1, 1 To 2)
  End If
  
  '今月基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult2(1 To lngRows2, 1 To 2)
  End If
  
  '前月のシートの比較位置
  lngComp1 = 1
  '今月のシートの比較位置
  lngComp2 = 1
  '前月のシート若しくは、今月のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        '所持金を比較
        vntTmp1 = rngList1.Offset(lngComp1, clngItems1).Value
        vntTmp2 = rngList2.Offset(lngComp2, clngItems2).Value
        If vntTmp1 <> vntTmp2 Then
          vntResult1(lngComp1, 1) = "金額変更"
          vntResult1(lngComp1, 2) = vntTmp2 - vntTmp1
          vntResult2(lngComp2, 1) = "金額変更"
          vntResult2(lngComp2, 2) = vntTmp2 - vntTmp1
        End If
        '前月、今月のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        lngComp2 = lngComp2 + 1
      Case Is = -1 '前月の固有値の場合
        vntResult1(lngComp1, 1) = "削除"
        '前月のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 '今月の固有値の場合
        vntResult2(lngComp2, 1) = "追加"
        '今月のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  '結果を出力
  rngList1.Offset(1, clngDiffer1).Resize(lngRows1, 2) = vntResult1
  rngList2.Offset(1, clngDiffer2).Resize(lngRows2, 2) = vntResult2
  
  '前月のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  '今月のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                vntKeys As Variant, _
                vntData As Variant) As Boolean

  Dim i As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用整列Keyを作成
    With .Offset(1, lngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
          Step:=1, Trend:=False
    End With
    'データをvntKeys1列で整列
    For i = UBound(vntKeys) To 0 Step -1
      DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
    Next i
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function

Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)

  With rngList
    '元データ順位を復帰
    DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngColumns)
    '復帰用Key列を削除
    .Offset(, lngColumns).EntireColumn.Delete
  End With

End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
            vntKeys2 As Variant, lngPos2 As Long) As Long

'  データの大小比較

  Dim i As Long
  Dim lngMax As Long
  
  If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
    DataCompare = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
    DataCompare = -1
    Exit Function
  End If
    
  lngMax = UBound(vntKeys1, 1)
  
  For i = 0 To lngMax
    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
      Exit For
    End If
  Next i
  
  If i > lngMax Then
    DataCompare = 0
  Else
    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
      DataCompare = -1
    Else
      DataCompare = 1
    End If
  End If
  
End Function

【64054】Re:ご協力お願いします。
お礼  初心者 E-MAIL  - 10/1/13(水) 20:38 -

引用なし
パスワード
   早速のご返信有難うございました!!

早速動かしてみましたが、思ったとおりの結果が得られました。

ほんとすばらしいです。

自分なりに中身を理解したいと思います。

Hirofumiさん、有難うございました。


▼Hirofumi さん:
>基本的にコードを変えてません
>変更した所は、
>各パラメタ(Constで定義されている定数と比較Keyの位置)
>定数項目2個追加(差異列の位置、前回は受注額の後ろとしていた物を独立に)
>変数を2個追加(差異計算用)
>データ復帰に使うKey列を作業列として、L列とX列を使用(前回は先頭No列)
>
>尚、前月Listの先頭に「担当課名」が有りませんが善いのですね?
> 「※A〜K列」と成っているのにレスでは「A〜J列」しか有りませんが?
> もし先頭列に「担当課名」が在るようなら、「★???」行を活かして下の行を削除して下さい
>
>Option Explicit
>Option Compare Text
>
>Public Sub DataMatch_2()
>
>  '前月のデータ列数(A列〜K列)
>  Const clngColumns1 As Long = 11
>  '受注額の列位置を指定(基準セルからの列Offset)
>'  Const clngItems1 As Long = 7 '★???
>  Const clngItems1 As Long = 6
>  '差異の列位置を指定(基準セルからの列Offset)
>'  Const clngDiffer1 As Long = 9 '★???
>  Const clngDiffer1 As Long = 8
>  
>  '今月のデータ列数(M列〜W列)
>  Const clngColumns2 As Long = 11
>  '受注額の列位置を指定(基準セルからの列Offset)
>  Const clngItems2 As Long = 7
>  '差異の列位置を指定(基準セルからの列Offset)
>  Const clngDiffer2 As Long = 9
>  
>  Dim rngList1 As Range
>  Dim vntList1 As Variant
>  Dim lngRows1 As Long
>  Dim lngComp1 As Long
>  Dim vntKeys1 As Variant
>  Dim vntResult1 As Variant
>  Dim vntTmp1 As Variant
>  
>  Dim rngList2 As Range
>  Dim vntList2 As Variant
>  Dim lngRows2 As Long
>  Dim lngComp2 As Long
>  Dim vntKeys2 As Variant
>  Dim vntResult2 As Variant
>  Dim vntTmp2 As Variant
>  
>  Dim lngMatch As Long
>  Dim strProm As String
>
>  '前月データシートのA1を基準とします
>  Set rngList1 = ActiveSheet.Range("A1")
>  
>  '今月データシートのA1を基準とする
>  Set rngList2 = ActiveSheet.Range("M1")
>  
>  '前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
>  'A列=0、C列=2、E列=4
>'  vntKeys1 = Array(2, 3) '★???
>  vntKeys1 = Array(1, 2)
>  '今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
>  'M列=0、O列=2、Q列=4
>  vntKeys2 = Array(2, 3)
>  
>  '前月の比較データを保持する配列を確保
>  ReDim vntList1(0 To UBound(vntKeys1))
>  '今月の比較データを保持する配列を確保
>  ReDim vntList2(0 To UBound(vntKeys1))
>  
>  '画面更新を停止
>  Application.ScreenUpdating = False
>  
>  '前月の基準に就いて
>  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
>    strProm = rngList1.Parent.Name & "にデータが有りません"
>    GoTo Wayout
>  Else
>    ReDim vntResult1(1 To lngRows1, 1 To 2)
>  End If
>  
>  '今月基準に就いて
>  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
>    strProm = rngList2.Parent.Name & "にデータが有りません"
>    GoTo Wayout
>  Else
>    ReDim vntResult2(1 To lngRows2, 1 To 2)
>  End If
>  
>  '前月のシートの比較位置
>  lngComp1 = 1
>  '今月のシートの比較位置
>  lngComp2 = 1
>  '前月のシート若しくは、今月のシートが最終行に達するまで繰り返し
>  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
>    '各列のデータを比較
>    lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
>    '比較結果に就いて
>    Select Case lngMatch
>      Case Is = 0 'Matchiした場合
>        '所持金を比較
>        vntTmp1 = rngList1.Offset(lngComp1, clngItems1).Value
>        vntTmp2 = rngList2.Offset(lngComp2, clngItems2).Value
>        If vntTmp1 <> vntTmp2 Then
>          vntResult1(lngComp1, 1) = "金額変更"
>          vntResult1(lngComp1, 2) = vntTmp2 - vntTmp1
>          vntResult2(lngComp2, 1) = "金額変更"
>          vntResult2(lngComp2, 2) = vntTmp2 - vntTmp1
>        End If
>        '前月、今月のシートの比較位置を更新
>        lngComp1 = lngComp1 + 1
>        lngComp2 = lngComp2 + 1
>      Case Is = -1 '前月の固有値の場合
>        vntResult1(lngComp1, 1) = "削除"
>        '前月のシートの比較位置を更新
>        lngComp1 = lngComp1 + 1
>      Case Is = 1 '今月の固有値の場合
>        vntResult2(lngComp2, 1) = "追加"
>        '今月のシートの比較位置を更新
>        lngComp2 = lngComp2 + 1
>    End Select
>  Loop
>  
>  '結果を出力
>  rngList1.Offset(1, clngDiffer1).Resize(lngRows1, 2) = vntResult1
>  rngList2.Offset(1, clngDiffer2).Resize(lngRows2, 2) = vntResult2
>  
>  '前月のシートの順位を復帰
>  DataRestore rngList1, lngRows1, clngColumns1
>  '今月のシートの順位を復帰
>  DataRestore rngList2, lngRows2, clngColumns2
>
>  strProm = "処理が完了しました"
>  
>Wayout:
>  
>  '画面更新を再開
>  Application.ScreenUpdating = True
>  
>  Set rngList1 = Nothing
>  Set rngList2 = Nothing
>  
>  MsgBox strProm, vbInformation
>  
>End Sub
>
>Private Function GetBasicData(rngList As Range, _
>                lngRows As Long, _
>                lngColumns As Long, _
>                vntKeys As Variant, _
>                vntData As Variant) As Boolean
>
>  Dim i As Long
>  
>  '基準に就いて
>  With rngList
>    '行数を取得
>    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
>    'データが無ければFunctionを抜ける(戻り値=False)
>    If lngRows <= 0 Then
>      Exit Function
>    End If
>    '復帰用Keyの出力列を挿入
>    .Offset(1, lngColumns).EntireColumn.Insert
>    '復帰用整列Keyを作成
>    With .Offset(1, lngColumns)
>      .Value = 1
>      .Resize(lngRows).DataSeries _
>          Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
>          Step:=1, Trend:=False
>    End With
>    'データをvntKeys1列で整列
>    For i = UBound(vntKeys) To 0 Step -1
>      DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
>    Next i
>    '比較用配列にデータを取得
>    For i = 0 To UBound(vntKeys)
>      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
>    Next i
>  End With
>  
>  GetBasicData = True
>
>End Function
>
>Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)
>
>  With rngList
>    '元データ順位を復帰
>    DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngColumns)
>    '復帰用Key列を削除
>    .Offset(, lngColumns).EntireColumn.Delete
>  End With
>
>End Sub
>
>Private Sub DataSort(rngScope As Range, _
>          rngKey As Range, _
>          Optional lngOrientation As Long = xlTopToBottom)
>
>  rngScope.Sort _
>      Key1:=rngKey, Order1:=xlAscending, _
>      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
>      Orientation:=lngOrientation, SortMethod:=xlStroke
>
>End Sub
>
>Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
>            vntKeys2 As Variant, lngPos2 As Long) As Long
>
>'  データの大小比較
>
>  Dim i As Long
>  Dim lngMax As Long
>  
>  If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
>    DataCompare = 1
>    Exit Function
>  End If
>  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
>    DataCompare = -1
>    Exit Function
>  End If
>    
>  lngMax = UBound(vntKeys1, 1)
>  
>  For i = 0 To lngMax
>    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
>      Exit For
>    End If
>  Next i
>  
>  If i > lngMax Then
>    DataCompare = 0
>  Else
>    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
>      DataCompare = -1
>    Else
>      DataCompare = 1
>    End If
>  End If
>  
>End Function

【64055】Re:ご協力お願いします。
発言  ご参考  - 10/1/13(水) 23:13 -

引用なし
パスワード
   既に解決したようですが、こんな方法もあります。

Sub datacheck()
  Dim dic1, dic2
  Dim s As String
  Dim k As Long
  Dim r1 As Long, r2 As Long
  Dim v1 As Long, v2 As Long
  Dim key
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  
  For k = 2 To [B1].End(xlDown).Row
    s = Cells(k, 2).Value & "_" & Cells(k, 3).Value
    dic1(s) = k
  Next
  
  For k = 2 To [G1].End(xlDown).Row
    s = Cells(k, 7).Value & "_" & Cells(k, 8).Value
    dic2(s) = k
  Next
  
  For Each key In dic1.keys
    r1 = dic1(key)
    If dic2.exists(key) Then
      r2 = dic2(key)
      v1 = Cells(r1, 4).Value
      v2 = Cells(r2, 9).Value
      If v1 <> v2 Then
        Cells(r2, 10).Value = "金額変更"
        Cells(r2, 11).Value = v2 - v1
      End If
    Else
      Cells(r1, 5).Value = "削除"
    End If
  Next
  
  For Each key In dic2.keys
    r2 = dic2(key)
    If Not dic1.exists(key) Then
      Cells(r2, 10).Value = "追加"
    End If
  Next
  
End Sub

【64060】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/14(木) 12:25 -

引用なし
パスワード
   けち付ける様で申し訳ありませんが?

Dictionaryは、1個で善い様な気がします?
前月分のKeyをDictionaryに登録する時間が無駄に成る様な気がしますが?
尚、セルの入出力の位置は、「初心者さん - 10/1/12(火) 22:19 -」に合わせました

Option Explicit

Sub datacheck_2()

  Dim dic2 As Object
  Dim r1 As Long, r2 As Long
  Dim v1 As Long, v2 As Long
  Dim key As String
 
  Dim lngCheck() As Long
  Dim rngMark As Range
  
  Set dic2 = CreateObject("Scripting.Dictionary")
 
  For r2 = 2 To [O1].End(xlDown).Row
    key = Cells(r2, 15).Value & "_" & Cells(r2, 16).Value
    dic2(key) = r2
  Next r2
  ReDim lngCheck(dic2.Count - 1)
  
  For r1 = 2 To [B1].End(xlDown).Row
    key = Cells(r1, 2).Value & "_" & Cells(r1, 3).Value
    If dic2.Exists(key) Then
      r2 = dic2(key)
      v1 = Cells(r1, 7).Value
      v2 = Cells(r2, 20).Value
      If v1 <> v2 Then
        Cells(r1, 9).Value = "金額変更"
        Cells(r1, 10).Value = v2 - v1
        Cells(r2, 22).Value = "金額変更"
        Cells(r2, 23).Value = v2 - v1
      End If
      lngCheck(r2 - 2) = 1
    Else
      Cells(r1, 9).Value = "削除"
    End If
  Next r1
 
  For r2 = 0 To UBound(lngCheck)
    If lngCheck(r2) = 0 Then
      Cells(r2 + 2, 22).Value = "追加"
    End If
  Next r2
 
  Set dic2 = Nothing
 
End Sub

【64065】Re:ご協力お願いします。
質問  初心者 E-MAIL  - 10/1/14(木) 22:41 -

引用なし
パスワード
   更なる回答、有難うございました。

もう1点確認です。

1.「物件名」で特定の単語が合致するものはその行を削除
2.「受注金額」で0のものはその行を削除

上記条件のどちらかを満たす行は削除するマクロを組みたいのですが、どのようにすればいいのでしょうか?

自分なりに考えてみました。

  Dim lRow As Long
  Dim i As Long
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = lRow To 2 Step -1
   If Cells(i, 8).Value = 0 Then
    Range(i & ":" & i).Delete
   End If
   Next i

これは2.の条件に合致する行を削除するために書いてみたのですが、動作は予想以上に遅かったです。
※全体で4000行近くあります。

また、1.の条件も複数の単語に対応したいと思います。
物件名に「AAA」を含む行、「BBB」を含む行、受注額に「0」を含む行 など。

よろしくお願いします。

【64066】Re:ご協力お願いします。
発言  Hirofumi  - 10/1/14(木) 23:37 -

引用なし
パスワード
   ▼初心者 さん:
>更なる回答、有難うございました。
>
>もう1点確認です。
>
>1.「物件名」で特定の単語が合致するものはその行を削除
>2.「受注金額」で0のものはその行を削除
>
>上記条件のどちらかを満たす行は削除するマクロを組みたいのですが、どのようにすればいいのでしょうか?
>
>自分なりに考えてみました。
>
>  Dim lRow As Long
>  Dim i As Long
>  lRow = Cells(Rows.Count, 1).End(xlUp).Row
>  For i = lRow To 2 Step -1
>   If Cells(i, 8).Value = 0 Then
>    Range(i & ":" & i).Delete
>   End If
>   Next i
>
>これは2.の条件に合致する行を削除するために書いてみたのですが、動作は予想以上に遅かったです。
>※全体で4000行近くあります。
>
>また、1.の条件も複数の単語に対応したいと思います。
>物件名に「AAA」を含む行、「BBB」を含む行、受注額に「0」を含む行 など。
>
>よろしくお願いします。

確認ですが?

1、此れは、突き合わせのマクロと同時に行うのですか?
 それとも、別のマクロにして別に行うのですか?
2、前月、当月両方とも行うのですか?
3、「初心者さん  - 10/1/13(水) 16:57 - 」のレスで
 前月の表の矛盾(担当課名列の有る無し)はどうなっているのでしょうか?

【64067】Re:ご協力お願いします。
発言  初心者  - 10/1/15(金) 8:52 -

引用なし
パスワード
   ▼Hirofumi さん:
>▼初心者 さん:
>>更なる回答、有難うございました。
>>
>>もう1点確認です。
>>
>>1.「物件名」で特定の単語が合致するものはその行を削除
>>2.「受注金額」で0のものはその行を削除
>>
>>上記条件のどちらかを満たす行は削除するマクロを組みたいのですが、どのようにすればいいのでしょうか?
>>
>>自分なりに考えてみました。
>>
>>  Dim lRow As Long
>>  Dim i As Long
>>  lRow = Cells(Rows.Count, 1).End(xlUp).Row
>>  For i = lRow To 2 Step -1
>>   If Cells(i, 8).Value = 0 Then
>>    Range(i & ":" & i).Delete
>>   End If
>>   Next i
>>
>>これは2.の条件に合致する行を削除するために書いてみたのですが、動作は予想以上に遅かったです。
>>※全体で4000行近くあります。
>>
>>また、1.の条件も複数の単語に対応したいと思います。
>>物件名に「AAA」を含む行、「BBB」を含む行、受注額に「0」を含む行 など。
>>
>>よろしくお願いします。
>
>確認ですが?
>
>1、此れは、突き合わせのマクロと同時に行うのですか?
> それとも、別のマクロにして別に行うのですか?
>2、前月、当月両方とも行うのですか?
>3、「初心者さん  - 10/1/13(水) 16:57 - 」のレスで
> 前月の表の矛盾(担当課名列の有る無し)はどうなっているのでしょうか?

詳細が伝えきれておらず申し訳ありません。
1.同時には実施せず、別で実施したいと考えています。
2.前月、当月共に実施したいと思います。
3.担当課名列は存在します。

何卒宜しくお願いします。

【64068】Re:ご協力お願いします。
発言  Hirofumi  - 10/1/15(金) 13:05 -

引用なし
パスワード
   データの量が多い場合に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

【64069】Re:ご協力お願いします。
発言  Hirofumi  - 10/1/15(金) 13:13 -

引用なし
パスワード
   ついでに、突き合わせ処理の速度向上版(Dictionary仕様)もUpします
行削除のマクロと同じ標準モジュールに入れて下さい

Public Sub CompareData()

'  突き合わせ処理(Dictionary使用)

  '前月のデータ列数(A列〜K列)
  Const clngColumns1 As Long = 11
  '今月のデータ列数(M列〜W列)
  Const clngColumns2 As Long = 11
  
  Dim rngList1 As Range
  Dim rngList2 As Range
  Dim strProm As String

  '前月データシートのA1を基準とします
  Set rngList1 = ActiveSheet.Range("A1")
  
  '今月データシートのA1を基準とする
  Set rngList2 = ActiveSheet.Range("M1")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  strProm = DataMatch(rngList1, clngColumns1, rngList2, clngColumns2)
  
  '画面更新を再開
  Application.ScreenUpdating = True

  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

'  Listの突き合わせ
'
'  rngList1:前月List先頭セル位置(見出し位置)
'  lngColumns1:Listの列数
'  rngList2:当月List先頭セル位置(見出し位置)
'  lngColumns2:Listの列数
'
'  戻り値:処理コメント
'
Private Function DataMatch(rngList1 As Range, lngColumns1 As Long, _
              rngList2 As Range, lngColumns2 As Long) As String

  '受注額の列位置を指定(基準セルからの列Offset)
  Const clngItems1 As Long = 7 '★???
  '差異の列位置を指定(基準セルからの列Offset)
  Const clngDiffer1 As Long = 9 '★???
  
  '受注額の列位置を指定(基準セルからの列Offset)
  Const clngItems2 As Long = 7
  '差異の列位置を指定(基準セルからの列Offset)
  Const clngDiffer2 As Long = 9
  
  Dim i As Long
  Dim j As Long
  Dim lngPos As Long
  
  Dim lngRows1 As Long
  Dim vntKeys1 As Variant
  Dim vntResult1 As Variant
  Dim vntTmp1 As Variant
  
  Dim lngRows2 As Long
  Dim vntKeys2 As Variant
  Dim vntResult2 As Variant
  Dim vntTmp2 As Variant
  
  Dim vntKey As Variant
  Dim vntList As Variant
  Dim dicIndex As Object
  Dim blnCheck() As Boolean

  '前月データシートのA1を基準とします
  Set rngList1 = ActiveSheet.Range("A1")
  
  '今月データシートのA1を基準とする
  Set rngList2 = ActiveSheet.Range("M1")
  
  '前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(2, 3) '★???
  '今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'M列=0、O列=2、Q列=4
  vntKeys2 = Array(2, 3)
  
  '比較データを保持する配列を確保
  ReDim vntList(UBound(vntKeys1))
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '今月基準に就いて
  If Not GetBasicData(rngList2, lngRows2, lngColumns2, vntKeys2, vntList) Then
    DataMatch = "今月にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult2(1 To lngRows2, 1 To 2)
  End If
  
  'Dictionaryオブジェクトに当月のKeyを登録
  With dicIndex
    For i = 1 To lngRows2
      vntKey = vntList(0)(i, 1)
      For j = 1 To UBound(vntList)
        vntKey = vntKey & vbTab & vntList(j)(i, 1)
      Next j
      .Item(vntKey) = i
    Next i
  End With
  ReDim blnCheck(1 To lngRows2)
    
  '前月の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, lngColumns1, vntKeys1, vntList) Then
    DataMatch = "前月にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult1(1 To lngRows1, 1 To 2)
  End If
  
  '当月データの先頭から最終まで繰り返し
  For i = 1 To lngRows1
    'Keyの作成
    vntKey = vntList(0)(i, 1)
    For j = 1 To UBound(vntList)
      vntKey = vntKey & vbTab & vntList(j)(i, 1)
    Next j
    'DictionaryにKeyがあるなら
    If dicIndex.Exists(vntKey) Then
      '当月の行位置を取得
      lngPos = dicIndex.Item(vntKey)
      '所持金を比較
      vntTmp1 = rngList1.Offset(i, clngItems1).Value
      vntTmp2 = rngList2.Offset(lngPos, clngItems2).Value
      If vntTmp1 <> vntTmp2 Then
        vntResult1(i, 1) = "金額変更"
        vntResult1(i, 2) = vntTmp2 - vntTmp1
        vntResult2(lngPos, 1) = "金額変更"
        vntResult2(lngPos, 2) = vntTmp2 - vntTmp1
      End If
      'チェックを入れる
      blnCheck(lngPos) = True
    Else
      vntResult1(i, 1) = "削除"
    End If
  Next i
        
  '今月のシートに追加を記入
  For i = 1 To lngRows2
    If Not blnCheck(i) Then
      vntResult2(i, 1) = "追加"
    End If
  Next i
  
  '結果を出力
  rngList1.Offset(1, clngDiffer1).Resize(lngRows1, 2) = vntResult1
  rngList2.Offset(1, clngDiffer2).Resize(lngRows2, 2) = vntResult2
  
  DataMatch = "突き合わせ処理が完了しました"
  
Wayout:
  
  Set dicIndex = Nothing
  
End Function

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                vntKeys As Variant, _
                vntData As Variant) As Boolean

  Dim i As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function

【64074】Re:ご協力お願いします。
質問  初心者  - 10/1/16(土) 22:29 -

引用なし
パスワード
   Hirofumi様、ご連絡有難う御座いました。

早速試してみたところ、以下の行でエラーが出てしまいました。

.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp

何が原因なのでしょうか?

【64075】Re:ご協力お願いします。
発言  かみちゃん E-MAIL  - 10/1/16(土) 22:34 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>早速試してみたところ、以下の行でエラーが出てしまいました。
>
>.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp

エラーメッセージと
変数lngRows、lngCount、lngColumnsの値を確認してみては?

確認方法としては、以下のような感じ。
MsgBox "lngRows=" & lngRows & vbCrLf & _
 "lngCount=" & lngCount & vbCrLf & _
  "lngColumns=" & lngColumns

【64076】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/16(土) 23:15 -

引用なし
パスワード
   取りあえず

>早速試してみたところ、以下の行でエラーが出てしまいました。
>
>.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp
>
>何が原因なのでしょうか?

先ず、エラーが出たなら、どんなエラーなのか書いて下さい
エラー内容が解らなければ対処できません!!
また、コードを何か変更しているならそれも書いて下さい

尚、下記コードの★印に就いて

' データ整理

  'データ列数(A列のみ)
'  Const clngColumns As Long = 1 '★削除
  'Keyと成る列を指定(基準セル位置からの列Offsetで指定:基準がA列なので0)
'  Const clngKeys As Long = 0 '★削除
  
テスト用のコードが残っていて不要なので削除して下さい

【64077】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/16(土) 23:27 -

引用なし
パスワード
   後、もう一点、くさい所が有りましたので、下記の★印のコードを1行追加して下さい

    '削除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

【64078】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/16(土) 23:45 -

引用なし
パスワード
   尚、「Exit For '★追加」が無くて

'削除行を削除
.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp

がエラーを起こすのは、同じ行の「物件名」が複数の削除条件に引っ掛かり
結果として、全データ行数を削除行が上回っている可能性が有ります
詰まり

lngRows - lngCount + 1 < 0

に成っていると思います

因って、「Exit For '★追加」を追加して治る様なら

  '「物件名」の削除条件を列挙(ウィルドカード使用可)
  '完全一致:"AAAA"、含む:"*AAAA*"
  '前方一致:"AAAA*"、後方一致:"*AAAA" ※「Like演算子」のHelp参照
  vntDelList = Array("AAA", "BBB*", "CCCC*", "*DDDDD*")

の削除条件が重なっていると思いますので確認して下さい
また、此れにより全行削除の可能性も有りますので
あくまで、Test用のデータで試して下さい

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

引用なし
パスワード
   詳細に伝えられず申し訳ないです。

早速「Exit For '★追加」を追加しましたが、

>'削除行を削除
>.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp

でエラーが生じました。

そこで、当初以下の条件で削除していたのですが、*保守*を削除したところエラーが消えました。

>  vntDelList = Array("*保守*", "*サマリ*")

複数の削除条件が引っかかってエラーが出ていたのでしょうか?


▼Hirofumi さん:
>尚、「Exit For '★追加」が無くて
>
>'削除行を削除
>.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp
>
>がエラーを起こすのは、同じ行の「物件名」が複数の削除条件に引っ掛かり
>結果として、全データ行数を削除行が上回っている可能性が有ります
>詰まり
>
>lngRows - lngCount + 1 < 0
>
>に成っていると思います
>
>因って、「Exit For '★追加」を追加して治る様なら
>
>  '「物件名」の削除条件を列挙(ウィルドカード使用可)
>  '完全一致:"AAAA"、含む:"*AAAA*"
>  '前方一致:"AAAA*"、後方一致:"*AAAA" ※「Like演算子」のHelp参照
>  vntDelList = Array("AAA", "BBB*", "CCCC*", "*DDDDD*")
>
>の削除条件が重なっていると思いますので確認して下さい
>また、此れにより全行削除の可能性も有りますので
>あくまで、Test用のデータで試して下さい

【64080】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/17(日) 8:56 -

引用なし
パスワード
   >詳細に伝えられず申し訳ないです。
>
>早速「Exit For '★追加」を追加しましたが、
>
>>'削除行を削除
>>.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp
>
>でエラーが生じました。
>
>そこで、当初以下の条件で削除していたのですが、*保守*を削除したところエラーが消えました。
>
>>  vntDelList = Array("*保守*", "*サマリ*")
>
>複数の削除条件が引っかかってエラーが出ていたのでしょうか?

いや、私のチョンボで「Exit For」を書き忘れていたのせいだけでは無いようですね?

実際に出たエラーの内容(エラーダイアログに書かれている物)と
その時の各変数の値が解らないので特定出来ないのですが?

.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp

がエラーを起こす可能性を考えてみます

1、「Resize プロパティ」に与える値、lngCount、lngColumnsのどちらかが0の場合
 a、lngColumns(List列数)は、このプロシージャに引数で与える呼び出し元の

  'Listの列数(A列〜K列)
  lngColumns1 = 11

  若しくは

  'Listの列数(M列〜W列)
  lngColumns2 = 11

  の値なので考えにくい
 b、lngCount(削除数)が0の場合は、

  With rngList
    '削除行が有るなら
    If lngCount > 0 Then

  で0の場合は実行しないので考えられない

2、「.Offset(lngRows - lngCount + 1)」の場合
 a、Offsetの前の拡張子"."が無い場合、コンパイルエラーが出て
  実行その物が出来ないので考えにくい
 b、削除するListが1行目から始まっている場合、lngRows - lngCount + 1が削除開始行なので
  lngRows - lngCount + 1 < 0に成った場合、詰まり削除行数がデータ行数を上回った場合
  エラーが出ます
  此れは、「Exit For」を書き忘れていた事により起きます
  原因は
  「Exit For」が在れば、
  「最初に合致した削除条件で削除の印を付け、削除する行数を足してLoopを抜ける」
  と言う動作をします  
  「Exit For」が無いと、
  「For〜NextのLoopを回り切り、その間で削除条件に合致した回数分
  削除数(lngCount)は加算される(印は同じ所に何度も付ける為、印は1つしか付かない)」
  という動作に成ります

  しかし、バグ修正で「Exit For」を正しい位置に追加すれば避けられると思います

因って、バグ修正で「Exit For」が正しい位置に追加されていれば、削除条件が重なっていても
正常に動くと思います

しかし、「Exit For」を追加してもエラーが回避されず、
削除条件の1つを外したら動いたと言うのも気に入りません?
私の考えている以外に原因が在ると思いますので

もう一度、削除List

  vntDelList = Array("*保守*", "*サマリ*")

を、元にもどしてTestして下さい
そして、エラーが出たら、ダイアログの文章をUpして下さい

次に、ダイアログの「デバグ」を押して下さい
すると、エラー行が反転表示されますので
lngColumns、lngCount、lngRowsの各変数にマウスポインタを持って行って変数の値をUpして下さい

次に、マクロを終了してExcelの画面に戻って下さい
各Listの最終列を見て下さい、其処に0か1が出力されています
(この0の行は残す行で1の行が削除されるぎょうです)
正常なら、Listの上に0が集まり、1が下に集まっていますので確認して下さい

【64081】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/17(日) 9:47 -

引用なし
パスワード
   因みに、「Exit For」が無くて、
削除Listの複数の削除削除条件に合致すると、
私の環境では以下のエラーメッセージが出ます

実行時エラー'1004'

アプリケーション定義またはオブジェクト定義のエラーです

【64082】Re:ご協力お願いします。
発言  かみちゃん E-MAIL  - 10/1/17(日) 10:01 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>>'削除行を削除
>>.Offset(lngRows - lngCount + 1).Resize(lngCount, lngColumns).Delete Shift:=xlShiftUp
>
>でエラーが生じました。

だから、エラーメッセージは何か?と聞いているのですが・・・
エラーメッセージが表示されているはずなので、それをお書きいただくことはできないのですか?

ちなみにこちらでは、エラーは発生していないようです。
(私が、質問に対して理解が不足しているような気もするのですが・・・)

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

引用なし
パスワード
   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は入っていません。

このような回答でよろしいでしょうか?

【64086】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/17(日) 16:10 -

引用なし
パスワード
   ▼初心者 さん:
>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して見て下さい
それを確認して見ます

【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して見て下さい
>それを確認して見ます

【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

【64090】Re:ご協力お願いします。
発言  Hirofumi  - 10/1/18(月) 7:16 -

引用なし
パスワード
   今回、勘違いでバグ持ちにしてしまって申し訳ありませんでしたが?

これからも、初心者さんがこの様な質問箱等に質問される事と思います
その時、コードがUpされ、其れを試した時にエラーが出た場合等で
「エラーが出ました」だけでは無く、必ずエラー内容と出来ればエラー行の
変数の値、詳しい状況をUpして頂ければ、対処が楽に成るのでお願いします

【64102】Re:ご協力お願いします。
お礼  初心者  - 10/1/19(火) 9:26 -

引用なし
パスワード
   いろいろと細かい対応を頂きありがとうございました。

次回以降、詳細な情報を伝えるよう努めていきます。

ありがとうございました。


▼Hirofumi さん:
>今回、勘違いでバグ持ちにしてしまって申し訳ありませんでしたが?
>
>これからも、初心者さんがこの様な質問箱等に質問される事と思います
>その時、コードがUpされ、其れを試した時にエラーが出た場合等で
>「エラーが出ました」だけでは無く、必ずエラー内容と出来ればエラー行の
>変数の値、詳しい状況をUpして頂ければ、対処が楽に成るのでお願いします

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