vbaマクロを使用して2つの異なるスプレッドシートから比較してコピーします

Question

Excelで次のマクロを使用するのに苦労します。シナリオ：2つの卓越性があります：1番目：マスターと2番目のアンケート回答。 Survey Responsesの各行をループして、各行の4列目の値を選択し、それをMaster全体の4列目と比較します。一致しない場合は、Survey Responsesの行全体をExcelの最後までコピーします。最初は、マスターには行がありませんので、調査回答からExcelのすべての行をコピーする必要があります。

Survey Responses Excel

以下のコードは、すべての行をループしないと私は比較を行わなくても二時間もまだコピーすべての行を実行する場合。

Here is the code what I am trying to use: 


'''''Define Object for Target Workbook 
Dim Target_Workbook As Workbook 
Dim Source_Workbook As Workbook 
Dim Source_Path As String 


'''''Assign the Workbook File Name along with its Path 
Source_Path = "C:\Users\Survey Responses\Survey Response.xls" 

Set Source_Workbook = Workbooks.Open(Source_Path) 
Set Target_Workbook = ThisWorkbook 


'''''With Source_Workbook object now, it is possible to pull any data from it 
'''''Read Data from Source File 


'''''Logic to select unique rows only 
Dim rngSource As Range, rngTarget As Range, cellSource As Range, cellTarget As Range 

Set rngSource = Source_Workbook.Sheets(1).Range("Responses") 
Set rngTarget = Target_Workbook.Sheets(2).Range("Responses") 

Dim rowNr_target As Integer, Rng As Range 


With Target_Workbook.Sheets(2) 
    rowNr_target = .Cells(.Rows.Count, "A").End(xlUp).Row 
End With 

Dim counter As Integer, found As Boolean, inner_counter As Integer 
counter = 1 

For Each cellSource In rngSource.Rows 
'On Error Resume Next 

    If cellSource.Cells(counter, 1).Value = "" Then 
     Exit For 
    End If 

    found = False 

    inner_counter = 1 

    For Each cellTarget In rngTarget.Rows 

     If cellTarget.Cells(inner_counter, 1).Value = "" Then 
      Exit For 
     End If 

     ''''test = Application.WorksheetFunction.VLookup(test1, rngTarget, 1, False) 
     If (cellSource.Cells(counter, 4) = cellTarget.Cells(inner_counter, 4)) Then 
      found = True 
      Exit For 
     End If 

     inner_counter = inner_counter + 1 

    Next 

    If (found = False) Then 
     cellSource.EntireRow.Copy 

     If (rowNr_target > 1) Then 
      rngTarget.Rows(rowNr_target + 1).Insert 
     Else 
      rngTarget.Rows(rowNr_target).Insert 
     End If 

     rowNr_target = rowNr_target + 1 
    End If 

    counter = counter + 1 
'On Error GoTo 0 

Next 

'''''Target_Workbook.Sheets(2).Range("Responses").Value = Source_data 


'''''Close Target Workbook 
Source_Workbook.Save 
Target_Workbook.Save 
''''Source_Workbook.Close False 

'''''Process Completed 
MsgBox "Task Completed" 

---

更新コード：

Dim cel As Range 
Dim rng As Range 
Dim r As Range 
Dim lastrow As Long 

Dim Target_Workbook As Workbook 
Dim Source_Workbook As Workbook 
Dim Source_Path As String 


'''''Assign the Workbook File Name along with its Path 
Source_Path = "C:\Users\Survey Responses\Survey Response.xls" 
Set Source_Workbook = Workbooks.Open(Source_Path) 
Set Target_Workbook = ThisWorkbook 

Dim rngSource As Range, rngTarget As Range, cellSource As Range, cellTarget As Range 

Set rngSource = Source_Workbook.Sheets(1).Range("Responses") 
Set rngTarget = Target_Workbook.Sheets(2).Range("Responses") 


    With Target_Workbook.Sheets(2) 
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row 

     For Each cel In Source_Workbook.Sheets(1).Range("D:D") 

      If cel.Value = "" Then 
       Exit For 
      End If 

      Set r = .Range("D:D").Find(What:=cel, LookIn:=xlFormulas, _ 
      LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
      MatchCase:=False, SearchFormat:=False) 

      If r Is Nothing Then 
       cel.EntireRow.Copy 
       rngTarget.Rows(lastrow).Insert 
       ''If Not rng Is Nothing Then Set rng = Union(rng, cel) Else Set rng = cel 
      End If 

     Next cel 

     ''rng.Copy.Range("A" & lastrow).PasteSpecial xlPasteValues 

    End With 

'''''Close Target Workbook 
Source_Workbook.Save 
Target_Workbook.Save 
''''Source_Workbook.Close False 

'''''Process Completed 
MsgBox "Task Completed" 

Answer 1

これはテストされていないコードですが、それはあなたが既に持っているもののお手伝いをする必要があります。範囲を自分に合わせて調整する必要がありますが、1枚のシートにループして存在しない値を収集し、別のシートにコピーします。

これを試してみてください

、

Sub dave() 
Dim cel As Range 
Dim rng As Range 
Dim r As Range 
Dim lastrow As Long 


    With Sheets("Master") 
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row 
     For Each cel In Sheets("Sheet1").Range("D1:D22") 
      Set r = .Range("D:D").Find(What:=cel, LookIn:=xlFormulas, _ 
     LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
     MatchCase:=False, SearchFormat:=False) 
      If r Is Nothing Then 
       If Not rng Is Nothing Then Set rng = Union(rng, cel) Else Set rng = cel 
      End If 
     Next cel 
     rng.Copy 
     .Range("A" & lastrow).PasteSpecial xlPasteValues 
    End With 
End Sub