Крест Ссылка на лист в основной лист данных

Question

У меня есть этот макрос, который позволяет перекрестно ссылаться на «Sheet2» в «Sheet1», где «Sheet1» - это лист, который будет содержать мои основные данные. Идея здесь состоит в том, чтобы сравнить лист 2 с основными данными и посмотреть, совпадает ли он. Проблема с этим макросом заключается в том, что она сравнивается только в пределах ограниченного диапазона. Мне было интересно, как сделать это более динамичным или гибким, если я добавлю еще один столбец, который также будет использоваться для перекрестной ссылки.

Вот пример моих листов.

Example: 

Sheet1 

Name     ID   Class Name   Taken? 
John Riley   0001   Painting   Yes 
Bob Johnson   0101   Painting   No 
Matthew Ward   1111   Math    Yes 


Sheet 2: 

Name     ID   Class Name   Taken? 
Matthew Ward   1111   Math    Yes 
Bob Johnson   0101   Painting   No 
Warren Renner  2222   Drama    No 
John Riley   0001   Painting   Yes 

Что нужно изменить в макросе, чтобы сравнить его, следует ли добавлять дополнительные столбцы в мои листы?

Example: 

Sheet1 

Name     ID   Class Name   Taken? Date Taken 
John Riley   0001   Painting   Yes  8/25/13 
Bob Johnson   0101   Painting   No 
Matthew Ward   1111   Math    Yes  9/20/10 


Sheet 2: 

Name     ID   Class Name   Taken?  Date Taken 
Matthew Ward   1111   Math    Yes  9/20/10 
Bob Johnson   0101   Painting   No   - 
Warren Renner  2222   Drama    No   - 
John Riley   0001   Painting   Yes  8/25/13 

Код:

Sub Compare_Data() 

Dim rngData2 As Range 
Dim rngData1 As Range 
Dim cell2 As Range 
Dim cell1 As Range 
Dim rLastCell As Range 


Set rngData2 = Worksheets("Sheet2").Range("B3", Worksheets("Sheet2").Range("B65536").End(xlUp)) 
Set rngData1 = Worksheets("Sheet1").Range("B3", Worksheets("Sheet1").Range("B65536").End(xlUp)) 


' Check customers in "Sheet2" to "Sheet1" 
For Each cell2 In rngData2 
    For Each cell1 In rngData1 
     With cell1 

      If .Offset(0, 0) = cell2.Offset(0, 0) And _ 
      .Offset(0, 1) = cell2.Offset(0, 1) And _ 
      .Offset(0, 2) = cell2.Offset(0, 2) And _ 
      .Offset(0, 3) = cell2.Offset(0, 3) Then 
       .Offset(0, -1).Range("A1:F1").Interior.ColorIndex = 3 
       cell2.Offset(0, 4) = .Offset(0, 4) 
      End If 



     End With 
    Next cell1 
Next cell2 

End Sub

Answer 1

Вот один из способов сделать макрос принимает любое число столбцов и повысить эффективность сравнения. Предполагая, что Лист 1 всегда сортируется по идентификатору, первое, что я хотел бы сделать, это SORT Sheet2 по ID. Это и изменение кода сравнения ускорит процесс сравнения. ПРИМЕЧАНИЕ. Если у вас есть тот же ID # с несколькими ClassNames, вам необходимо отсортировать листы 1 & 2 от Col B и C, чтобы процесс сравнения работал. Во-вторых, это изменить код сравнения, так как он сравнивает каждую строку на листе1 с каждой строкой на листе2 для всех строк в листах, независимо от того, содержат они данные или нет, ужасно, неэффективно.

Sub Compare_Data() 
Dim FirstRow As Long, FirstCol As Long, LastRow As Long, LastCol As Long 
Dim SortSheet2 As Range 
Dim S1LastRow As Double, S2LastRow As Double 
ActiveWorkbook.Worksheets("Sheet2").Select ' find used range, name it, sort it 
FirstRow = Cells.Find(What:="*", SearchDirection:=xlNext, SearchOrder:=xlByRows).Row 
FirstCol = Cells.Find(What:="*", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column 
LastRow = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 
LastCol = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column 
Set SortSheet2 = Range(Cells(FirstRow, FirstCol), Cells(LastRow, LastCol)) 
SortSheet2.Select 
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear 
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range(Cells(1, "B"), Cells(LastRow, "B")), _ 
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
With ActiveWorkbook.Worksheets("Sheet2").Sort 
    .SetRange Range("SortSheet2") 
    .Header = xlYes 
    .MatchCase = False 
    .Orientation = xlTopToBottom 
    .SortMethod = xlPinYin 
    .Apply 
End With 
Range("A1").Select 
Dim S1ID As Variant, S2ID As Variant, S1RowCntr As Long, S2RowCntr As Long, ColCnt As Long 
S1RowCntr = 1 
S2RowCntr = 1 
ColCnt = 3 ' starting at Col C for the compare function 
Application.ScreenUpdating = False 'set to True for troubleshooting 
ActiveWorkbook.Worksheets("Sheet1").Select 
Do Until IsEmpty(ActiveCell) ' loop thru Sheet 1 ID numbers 
    S1RowCntr = S1RowCntr + 1 
    Range(Cells(S1RowCntr, ColCnt - 1), Cells(S1RowCntr, ColCnt - 1)).Select 
    S1Data = ActiveCell.Address 
    S1ID = Range(S1Data).Value 
    ActiveWorkbook.Worksheets("Sheet2").Activate 
    S2RowCntr = S2RowCntr + 1 
    Range(Cells(S2RowCntr, "B"), Cells(S2RowCntr, "B")).Activate 
    S2Data = ActiveCell.Address 
    S2ID = Range(S2Data).Value 
    If S2ID = S1ID Then 
     ' 
     Done = Equals(ColCnt, S1RowCntr, S2RowCntr, LastCol) 
    Else 
     Do Until S1ID = S2ID Or S2ID = "" 
      S2RowCntr = S2RowCntr + 1 
      Range(Cells(S2RowCntr, "B"), Cells(S2RowCntr, "B")).Select 
      S2Data = ActiveCell.Address 
      S2ID = Range(S2Data).Value 
     Loop 
     If S2ID = "" Then 
      'Do nothing 
     ElseIf S1ID = S2ID Then 
      Done = Equals(ColCnt, S1RowCntr, S2RowCntr, LastCol) 
     End If 
    End If 
    ColCnt = 3 
    ActiveWorkbook.Worksheets("Sheet1").Select 
Loop 
ActiveWorkbook.Worksheets("Sheet1").Select 
Range("A1").Select 
End Sub 
Function Equals(ByVal ColCnt As Long, ByVal S1RowCntr As Long, ByVal S2RowCntr As Long, ByVal LastCol As Long) 
Same = True 'if the values are the same continue to compare all the columns 
      ' if any value is false, stop and highlight, again efficient 
Do Until ColCnt > LastCol Or Same = False 
    ActiveWorkbook.Worksheets("Sheet1").Select 
    Range(Cells(S1RowCntr, ColCnt), Cells(S1RowCntr, ColCnt)).Select 
    S1Data = ActiveCell.Address 
    Class = Range(S1Data).Value 
    ActiveWorkbook.Worksheets("Sheet2").Select 
    Range(Cells(S2RowCntr, ColCnt), Cells(S2RowCntr, ColCnt)).Select 
    S2Data = ActiveCell.Address 
    Taken = Range(S2Data).Value 
    If Taken = Class Then 
     Same = True 
    Else 
     ActiveWorkbook.Worksheets("Sheet1").Select 
     Range(Cells(S1RowCntr, "A"), Cells(S1RowCntr, LastCol)).Select 
     With Selection 
      .Interior.ColorIndex = 3 
     End With 
     Same = False 
    End If 
    ColCnt = ColCnt + 1 
Loop 
End Function