Excel VBA質問箱 IV

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

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


6422 / 13646 ツリー ←次へ | 前へ→

【45208】シートを比較し、一致しない行を抽出したい Wz 06/12/15(金) 15:05 質問[未読]
【45209】Re:シートを比較し、一致しない行を抽出し... Wz 06/12/15(金) 15:40 質問[未読]
【45210】Re:シートを比較し、一致しない行を抽出し... maverick 06/12/15(金) 16:21 回答[未読]
【45212】Re:シートを比較し、一致しない行を抽出し... Wz 06/12/15(金) 16:53 発言[未読]
【45215】Re:シートを比較し、一致しない行を抽出し... maverick 06/12/15(金) 17:13 発言[未読]
【45213】Re:シートを比較し、一致しない行を抽出し... Kein 06/12/15(金) 16:55 回答[未読]
【45217】Re:シートを比較し、一致しない行を抽出し... Wz 06/12/15(金) 17:22 発言[未読]
【45224】Re:シートを比較し、一致しない行を抽出し... maverick 06/12/15(金) 18:40 回答[未読]
【45229】Re:シートを比較し、一致しない行を抽出し... Kein 06/12/15(金) 19:45 発言[未読]
【45242】Re:シートを比較し、一致しない行を抽出し... Kein 06/12/16(土) 15:29 回答[未読]
【45226】Re:シートを比較し、一致しない行を抽出し... Hirofumi 06/12/15(金) 18:57 回答[未読]
【45234】Re:シートを比較し、一致しない行を抽出し... Hirofumi 06/12/16(土) 1:05 回答[未読]
【45235】Re:シートを比較し、一致しない行を抽出し... Hirofumi 06/12/16(土) 6:16 回答[未読]
【45275】Re:シートを比較し、一致しない行を抽出し... Hirofumi 06/12/17(日) 20:38 回答[未読]
【45324】Re:シートを比較し、一致しない行を抽出し... Wz 06/12/19(火) 13:33 お礼[未読]

【45208】シートを比較し、一致しない行を抽出した...
質問  Wz  - 06/12/15(金) 15:05 -

引用なし
パスワード
   お世話になります。

過去ログで似たような情報が結構あるのですが、改造してもどうもうまくいかないのでご教授ください。

内容は、シート1と2のA〜E列にあるデータを比較し、A〜D列が一致しない行を
シート3に書き出したいと思っています。

過去ログではB列が一致したものをシート3に書き出す
といったマクロはあったのですが、改造してもうまくうごきませんでした。

シート1、2、3ともにサンプルはこんな感じです

  A   B   C   D   E
1 名前 記号 時間 数値 記号 
2 名前 記号 時間 数値 記号

よろしくお願いします。

【45209】Re:シートを比較し、一致しない行を抽出...
質問  Wz  - 06/12/15(金) 15:40 -

引用なし
パスワード
   補足ですが
データ量は結構多く、数千行あります。
抽出するデータも千行は超えると思われます。

処理は多少重くても構いませんのでよろしくお願いします。

【45210】Re:シートを比較し、一致しない行を抽出...
回答  maverick  - 06/12/15(金) 16:21 -

引用なし
パスワード
   Sub test()
  Dim sh(1 To 3) As Worksheet
  Dim i As Long, j As Long
  Dim cflg As Boolean

  For i = 1 To 3
    Set sh(i) = Worksheets(i)
  Next i

  Application.ScreenUpdating = False
  For i = 1 To sh(1).Range("A65536").End(xlUp).Row
    cflg = False
    For j = 1 To 4
      If sh(1).Cells(i, j).Value <> sh(2).Cells(i, j).Value Then cflg = True
    Next j
    If cflg = True Then sh(3).Cells(i, 1).Resize(, 5).Value = sh(2).Cells(i, 1).Resize(, 5).Value
  Next i
  Application.ScreenUpdating = True

  For i = 1 To 3
    Set sh(i) = Nothing
  Next i
End Sub

【45212】Re:シートを比較し、一致しない行を抽出...
発言  Wz  - 06/12/15(金) 16:53 -

引用なし
パスワード
   ▼maverick さん:

回答ありがとうございます。
しかしながら動作はするものの、思っていた結果は得られませんでした。

シート2がそのまま、シート1の行数分だけシート3にコピーされているようです。

もしかしてサンプルの書き方が悪かったかもしれませんが
シート1,2ともにA〜E列のどの項目も、同じ内容が複数存在しています。

例えば
A   B   C  D
1/1 Aさん 10 ああ
1/1 Aさん 3  いい
1/1 Bさん 8  ああ
1/2 Cさん 10 ああ

といったデータで、内容はかなり重複しています。
(同じシート内でA〜D列全てが同じものはありません)

これが原因なのかはわかりませんが、自分なりに、いただいたソースで
勉強してみます。

【45213】Re:シートを比較し、一致しない行を抽出...
回答  Kein  - 06/12/15(金) 16:55 -

引用なし
パスワード
   Sheet1 と Sheet2 のデータのうち、どちらをSheet3に抽出すればよいか
書いてないので、"A:E列には Sheet1 のデータ,G:K列には Sheet2 のデータ"
を抽出することとします。以下のマクロを試してみて下さい。

Sub Get_Def_Value()
  Dim LR As Long, LR2 As Long
 
  LR = Sheets("Sheet1").Range("A65536").End(xlUp).Row
  With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
  End With
  With Sheets("Sheet3")
   .Range("A1:A" & LR).Formula = _
   "=CONCATENATE(Sheet1!A1,"","",Sheet1!B1,"",""," & _
   "Sheet1!C1,"","",Sheet1!D1)"
   .Range("E1:E" & LR).Formula = "=Sheet1!E1"
   .Range("G1:G" & LR).Formula = _
   "=CONCATENATE(Sheet2!A1,"","",Sheet2!B1,"",""," & _
   "Sheet2!C1,"","",Sheet2!D1)"
   .Range("K1:K" & LR).Formula = "=Sheet2!E1"
   With .Range("A1:K" & LR)
     .Copy
     .PasteSpecial xlPasteValues
     .Range("A:A,G:G").RowDifferences(.Range("G1")) _
     .Offset(, 5).Value = 1
     .Sort Key1:=.Columns(6), Order1:=xlAscending, _
     Header:=xlNo, Orientation:=xlSortColumns
   End With
   LR2 = .Range("F65536").End(xlUp).Row + 1
   .Rows(LR & ":" & LR2).ClearContents
   .Range("F:F").ClearContents
   .Range("A:A").TextToColumns _
    DataType:=xlDelimited, Comma:=True
   .Range("G:G").TextToColumns _
    DataType:=xlDelimited, Comma:=True
  End With
  With Application
   .Goto Sheets("Sheet3").Range("A1"), True
   .CutCopyMode = False
   .ScreenUpdating = True
   .DisplayAlerts = True
  End With
End Subぬ

【45215】Re:シートを比較し、一致しない行を抽出...
発言  maverick  - 06/12/15(金) 17:13 -

引用なし
パスワード
   シート1
A   B   C  D
1/1 Aさん 10 ああ
1/1 Aさん 3  いい
1/1 Bさん 8  ああ
1/2 Cさん 10 ああ

シート2
A   B   C  D
1/1 Aさん 10 ああ
1/1 Aさん 3  いい
1/1 Bさん 8  あい
1/2 Cさん 10 ああ

↓↓↓↓

シート3
A   B   C  D
 
 
1/1 Bさん 8  あい
 

となるようにしましたが、違いましたか?

【45217】Re:シートを比較し、一致しない行を抽出...
発言  Wz  - 06/12/15(金) 17:22 -

引用なし
パスワード
   ▼Kein さん:
 回答ありがとうございます。
時間がなくなってしまったので月曜日にためさせていただきます。


▼maverickさん:
 説明不足で申し訳ありません。
「一致しない」行と書いたのがまずかったのかもしれません。
正確にはシート2にはあって、シート1に存在しない行を抽出したいのです。
シート1の行は基本的には全てシート2には含まれています。

まずい説明で申し訳ありませんでしたm(__)m

【45224】Re:シートを比較し、一致しない行を抽出...
回答  maverick  - 06/12/15(金) 18:40 -

引用なし
パスワード
   ▼Wz さん:

>内容は、シート1と2のA〜E列にあるデータを比較し、A〜D列が一致しない行を
>シート3に書き出したいと思っています。

↑この質問と

>正確にはシート2にはあって、シート1に存在しない行を抽出したいのです。
>シート1の行は基本的には全てシート2には含まれています。

↑この質問とでは質問内容が全く違います!


Sub test()
  Dim sh(1 To 3) As Worksheet
  Dim i As Long, j As Long
  Dim shd As Object
  Dim tmp As String

  For i = 1 To 3
    Set sh(i) = Worksheets(i)
  Next i
  Set shd = CreateObject("Scripting.Dictionary")
  
  Application.ScreenUpdating = False
  For i = 1 To sh(1).Range("A65536").End(xlUp).Row
    tmp = ""
    For j = 1 To 4
      tmp = tmp & sh(1).Cells(i, j).Value
    Next j
    shd.Add tmp, i
  Next i
  
  For i = 1 To sh(2).Range("A65536").End(xlUp).Row
    tmp = ""
    For j = 1 To 4
      tmp = tmp & sh(2).Cells(i, j).Value
    Next j
    If shd.Exists(tmp) = False Then sh(3).Cells(i, 1).Resize(, 5).Value = sh(2).Cells(i, 1).Resize(, 5).Value
  Next i
  Application.ScreenUpdating = True

  For i = 1 To 3
    Set sh(i) = Nothing
  Next i
  Set shd = Nothing
End Sub

【45226】Re:シートを比較し、一致しない行を抽出...
回答  Hirofumi  - 06/12/15(金) 18:57 -

引用なし
パスワード
   Testしていないので上手く行かないかも?
以下を標準モジュールに記述して下さい

Option Explicit
Option Compare Text

Public Sub DataMatch()

'  固有データのチェック

  'Sheet1のデータ列数(A列〜E列)
  Const clngColumns1 As Long = 5
  'Sheet2のデータ列数(A列〜E列)
  Const clngColumns2 As Long = 5
  
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim lngMatch As Long
  Dim rngResult As Range
  Dim lngWrite As Long
  Dim strProm As String

  'Sheet1データシートのA1を基準とします
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2データシートのA1を基準とする
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  '出力シートの基準位置を設定
  Set rngResult = Worksheets("Sheet3").Cells(1, "A")
  
  'Sheet1の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(0, 1, 2, 3)
  'Sheet2の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(0, 1, 2, 3)
  
  'Sheet1の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  'Sheet2の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet1の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet2基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet1のシートの比較位置
  lngComp1 = 1
  'Sheet2のシートの比較位置
  lngComp2 = 1
  'Sheet1のシート若しくは、Sheet2のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = IsSame(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
      Case Is = -1 'Sheet1の固有値の場合
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 'Sheet2の固有値の場合
        '出力行位置を更新
        lngWrite = lngWrite + 1
        '行を出力
        rngList2.Offset(lngComp2).Resize(, clngColumns2).Copy _
            Destination:=rngResult.Offset(lngWrite)
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  'Sheet1のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  
  'Sheet2のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  Set rngResult = 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
  Dim lngNumb() 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を作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データを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(1, 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 IsSame(vntKeys1 As Variant, lngPos1 As Long, _
            vntKeys2 As Variant, lngPos2 As Long) As Long

'  データの大小比較

  Dim i As Long
  Dim lngMax As Long
  
  '比較位置がDataEndを超えた場合
  If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
    IsSame = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
    IsSame = -1
    Exit Function
  End If
    
  '1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
  lngMax = UBound(vntKeys1, 1)
  
  '1行のKeyを先頭から比較
  For i = 0 To lngMax
    'もし、Keyが不一致なら
    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
      'Forを抜ける
      Exit For
    End If
  Next i
  
  'Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
  If i > lngMax Then
    '戻り値の値として、「等しい」を返す
    IsSame = 0
  Else
    'vntKeys1の値が、vntKeys2の値因り小さい場合
    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
      '戻り値の値として、「小さい」を返す
      IsSame = -1
    Else
      '戻り値の値として、「大きい」を返す
      IsSame = 1
    End If
  End If
  
End Function

【45229】Re:シートを比較し、一致しない行を抽出...
発言  Kein  - 06/12/15(金) 19:45 -

引用なし
パスワード
   その内容なら、私のコードは適切ではなくなります。

【45234】Re:シートを比較し、一致しない行を抽出...
回答  Hirofumi  - 06/12/16(土) 1:05 -

引用なし
パスワード
   書き忘れが有りました
尚、Sheet1、Sheet2共に列見出しが有る物としています
また、各シートの基準セル位置は、一番左の列見出しのセル位置です

【45235】Re:シートを比較し、一致しない行を抽出...
回答  Hirofumi  - 06/12/16(土) 6:16 -

引用なし
パスワード
   WinXp等で、リソースに余裕が有るならこの方が、処理が速く成ります

Option Explicit
Option Compare Text

Public Sub DataMatch2()

'  固有データのチェック

  'Sheet1のデータ列数(A列〜E列)
  Const clngColumns1 As Long = 5
  'Sheet2のデータ列数(A列〜E列)
  Const clngColumns2 As Long = 5
  
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim lngMatch As Long
  Dim rngResult As Range
  Dim lngCount As Long
  Dim lngSort() As Long
  Dim strProm As String

  'Sheet1データシートのA1を基準とします
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2データシートのA1を基準とする
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  '出力シートの基準位置を設定
  Set rngResult = Worksheets("Sheet3").Cells(1, "A")
  
  'Sheet1の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(0, 1, 2, 3)
  'Sheet2の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(0, 1, 2, 3)
  
  'Sheet1の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  'Sheet2の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet1の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet2基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  '抽出Flagの配列を確保
  ReDim lngSort(1 To lngRows2, 1 To 1)
  
  'Sheet1のシートの比較位置
  lngComp1 = 1
  'Sheet2のシートの比較位置
  lngComp2 = 1
  'Sheet1のシート若しくは、Sheet2のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = IsSame(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
      Case Is = -1 'Sheet1の固有値の場合
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 'Sheet2の固有値の場合
        '抽出数をカウント
        lngCount = lngCount + 1
        '抽出Flagを立てる
        lngSort(lngComp2, 1) = 1
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  'Sheet1のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  
  With rngList2
    '抽出Flagを出力
    .Offset(1, clngColumns2 + 1).Resize(lngRows2).Value = lngSort
    '抽出FlagをKeyとして整列
    DataSort .Offset(1).Resize(lngRows2, clngColumns2 + 2), .Offset(1, clngColumns2 + 1)
    'データをCopy
    .Offset(lngRows2 - lngCount + 1).Resize(lngCount, clngColumns2).Copy _
        Destination:=rngResult.Offset(1)
    '抽出Flagを削除
    .Offset(1, clngColumns2 + 1).EntireColumn.Delete
  End With
  'Sheet2のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

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

尚、以下のプロシージャは、前回の物と同じ物を使います

「Private Function GetBasicData」
「Private Sub DataRestore」
「Private Sub DataSort」
「Private Function IsSame」

【45242】Re:シートを比較し、一致しない行を抽出...
回答  Kein  - 06/12/16(土) 15:29 -

引用なし
パスワード
   本来なら、質問内容を変えたら再回答はしないのですが、いちおう今回に限り
組み直したサンプルコードを提示しておきます。

Sub Get_Def_Value2()
  Dim LRa As Long, LRb As Long
 
  LRa = Sheets("Sheet1").Range("A65536").End(xlUp).Row
  LRb = Sheets("Sheet2").Range("A65536").End(xlUp).Row
  Application.ScreenUpdating = False
  With Sheets("Sheet3")
   .Range("A1:A" & LRb).Formula = _
   "=CONCATENATE(Sheet2!A1,"","",Sheet2!B1,"",""," & _
   "Sheet2!C1,"","",Sheet2!D1)"
   .Range("E1:E" & LRb).Formula = "=Sheet2!E1"
   .Range("F1:F" & LRa).Formula = _
   "=CONCATENATE(Sheet1!A1,"","",Sheet1!B1,"",""," & _
   "Sheet1!C1,"","",Sheet1!D1)"
   With .Range("A:F")
     .Copy
     .PasteSpecial xlPasteValues
   End With
   With .Range("H1:H" & LRb)
     .Formula = "=MATCH($A1,$F$1:$F$" & LRa & ",0)"
     If WorksheetFunction.Count(.Cells) = LRb Then
      MsgBox "存在しないデータは見つかりませんでした", 64
      .Parent.Cells.ClearContents: GoTo ELine
     End If
     .SpecialCells(3, 1).EntireRow.ClearContents
   End With
   .Range("F:H").ClearContents
   With .Range("A:E")
     .Columns(1).TextToColumns DataType:=xlDelimited, _
     Comma:=True
     .Sort Key1:=.Columns(1), Order1:=xlAscending, _
     Header:=xlNo, Orientation:=xlSortColumns
   End With
  End With
ELine:
  With Application
   .Goto Sheets("Sheet3").Range("A1"), True
   .CutCopyMode = False
   .ScreenUpdating = True
  End With
End Sub

【45275】Re:シートを比較し、一致しない行を抽出...
回答  Hirofumi  - 06/12/17(日) 20:38 -

引用なし
パスワード
   善く見ると、C列が時間ですね?
時間がシリアル値だと、倍精度実数の比較に成るので上手く行かない可能性が有るので
其の処理を入れたのと、小さい配列で済ます様に変更して、
少し遅く成りますが、リソースの使用量を減らしています

Option Explicit
Option Compare Text

Public Sub DataMatch3()

'  固有データのチェック(行処理版)

  'Sheet1のデータ列数(A列〜E列)
  Const clngColumns1 As Long = 5
  '時刻の列位置(基準セル位置からの列Offset:C列)
  Const clngTime1 As Long = 2
  'Sheet2のデータ列数(A列〜E列)
  Const clngColumns2 As Long = 5
  '時刻の列位置(基準セル位置からの列Offset:C列)
  Const clngTime2 As Long = 2
  
  Dim rngList1 As Range
  Dim vntData1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim rngList2 As Range
  Dim vntData2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim lngMatch As Long
  Dim rngResult As Range
  Dim lngCount As Long
  Dim lngSort() As Long
  Dim strProm As String

  'Sheet1データシートのA1を基準とします
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2データシートのA1を基準とする
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  '出力シートの基準位置を設定
  Set rngResult = Worksheets("Sheet3").Cells(1, "A")
  
  'Sheet1の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(0, 1, 2, 3)
  'Sheet2の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(0, 1, 2, 3)
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet1の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet2基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  '抽出Flagの配列を確保
  ReDim lngSort(1 To lngRows2, 1 To 1)
  
  'Sheet1のシートの比較位置
  lngComp1 = 1
  'Sheet2のシートの比較位置
  lngComp2 = 1
  'Sheet1のシート若しくは、Sheet2のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '比較位置がDataEndを超えた場合
    If lngComp1 > lngRows1 Then
      lngMatch = 1
    ElseIf lngComp2 > lngRows2 Then
      lngMatch = -1
    Else
      '比較位置の行データを取得
      vntData1 = rngList1.Offset(lngComp1).Resize(, clngColumns1).Value
      vntData2 = rngList2.Offset(lngComp2).Resize(, clngColumns2).Value
      '★時刻のシリアル値を文字列に変換(時刻がシリアル値で無い場合、以下2行削除)
      vntData1(1, clngTime1 + 1) = Format(vntData1(1, clngTime1 + 1), "hh:mm:ss")
      vntData2(1, clngTime2 + 1) = Format(vntData2(1, clngTime2 + 1), "hh:mm:ss")
      '各列のデータを比較
      lngMatch = DataCompare(vntData1, vntKeys1, vntData2, vntKeys2)
    End If
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
      Case Is = -1 'Sheet1の固有値の場合
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 'Sheet2の固有値の場合
        '抽出数をカウント
        lngCount = lngCount + 1
        '抽出Flagを立てる
        lngSort(lngComp2, 1) = 1
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  'Sheet1のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  
  With rngList2
    '抽出Flagを出力
    .Offset(1, clngColumns2 + 1).Resize(lngRows2).Value = lngSort
    '抽出FlagをKeyとして整列
    DataSort .Offset(1).Resize(lngRows2, clngColumns2 + 2), .Offset(1, clngColumns2)
    DataSort .Offset(1).Resize(lngRows2, clngColumns2 + 2), .Offset(1, clngColumns2 + 1)
    'データをCopy
    .Offset(lngRows2 - lngCount + 1).Resize(lngCount, clngColumns2).Copy _
        Destination:=rngResult.Offset(1)
    '抽出Flagを削除
    .Offset(1, clngColumns2 + 1).EntireColumn.Delete
  End With
  'Sheet2のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

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

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

  Dim i As Long
  Dim lngNumb() 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を作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データをvntKeys1列で整列
    For i = UBound(vntKeys) To 0 Step -1
      DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
    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(1, 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(vntData1 As Variant, vntKeys1 As Variant, _
              vntData2 As Variant, vntKeys2 As Variant) As Long

'  データの大小比較

  Dim i As Long
  Dim lngMax As Long
      
  '1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
  lngMax = UBound(vntKeys1, 1)
  
  '1行のKeyを先頭から比較
  For i = 0 To lngMax
    'もし、Keyが不一致なら
    If vntData1(1, vntKeys1(i) + 1) <> vntData2(1, vntKeys2(i) + 1) Then
      'Forを抜ける
      Exit For
    End If
  Next i
  
  'Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
  If i > lngMax Then
    '戻り値の値として、「等しい」を返す
    DataCompare = 0
  Else
    'vntKeys1の値が、vntKeys2の値因り小さい場合
    If vntData1(1, vntKeys1(i) + 1) < vntData2(1, vntKeys2(i) + 1) Then
      '戻り値の値として、「小さい」を返す
      DataCompare = -1
    Else
      '戻り値の値として、「大きい」を返す
      DataCompare = 1
    End If
  End If
  
End Function

【45324】Re:シートを比較し、一致しない行を抽出...
お礼  Wz  - 06/12/19(火) 13:33 -

引用なし
パスワード
   返答が遅くなりましたが、皆様ありがとうございます!

クリティカルに思い通りの結果が得られました!

また曖昧な質問のせいで二度手間をとらせてしまい申し訳ありませんでした。
次回からは気をつけます。

本当にありがとうございましたm(__)m

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