0

我有这个宏允许您在“Sheet1”中交叉引用“Sheet2”，其中“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

结束子

4

1 回答 1

0

这是使宏接受任意数量的列并提高比较效率的一种方法。假设 Sheet 1 始终按 ID 排序，我要做的第一件事是按 ID 排序 Sheet2。这和更改比较代码将加快比较过程。注意：如果您有相同的 ID # 和多个 ClassName，您需要按 Col B 和 C 对工作表 1 和 2 进行排序，以便比较过程起作用。第二件事是更改比较代码，因为它是代码将 sheet1 上的每一行与 sheet2 上的每一行进行比较，用于工作表中的所有行，无论它们是否包含数据，非常低效。

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
于 2014-05-31T10:59:25.427 回答