我有一个工作簿，其中包含2个工作表和子工作表，按产品系列列命名：
它们都有相同的标题，在列标题中有一个uniqueID列。
我想在这两张纸之间匹配uniqueID：
我想要一个新按钮，按下时，Master Page中的UniqueID将与每个子表的Unique Id列进行比较，并且：
我想用VBA宏来完成上面的事情。我附上了一份excel https://dl.dropboxusercontent.com/u/29585269/Sample.xlsx的样本。
如果您需要任何其他信息，请与我们联系。
答案 0 :(得分：1)
我在网上遇到了一些代码并根据我的需要进行了修改。
所以，这是怎么回事：
您的PL表格旁边有3张主要表格 - 子表格（钻孔和修井，钓鱼，班轮系统，专业服务，井筒清洁）：
此代码将打印原始工作表和更新工作表之间的更改：
Option Explicit
Sub CompareSheets()
'
' constants
' worksheets & ranges
' original
Const ksWSOriginal = "ORIGINAL"
Const ksOriginal = "OriginalTable"
Const ksOriginalKey = "OriginalKey"
' updated
Const ksWSUpdated = "UPDATED"
Const ksUpdated = "UpdatedTable"
Const ksUpdatedKey = "UpdatedKey"
' changes
Const ksWSChanges = "CHANGES"
Const ksChanges = "ChangesTable"
' labels
Const ksChange = "CHANGE"
Const ksRemove = "REMOVE"
Const ksAdd = "ADD"
'
' declarations
Dim rngO As Range, rngOK As Range, rngU As Range, rngUK As Range, rngC As Range
Dim c As Range
Dim I As Long, J As Long, lChanges As Long, lRow As Long, bEqual As Boolean
'
' start
Set rngO = Worksheets(ksWSOriginal).Range(ksOriginal)
Set rngOK = Worksheets(ksWSOriginal).Range(ksOriginalKey)
Set rngU = Worksheets(ksWSUpdated).Range(ksUpdated)
Set rngUK = Worksheets(ksWSUpdated).Range(ksUpdatedKey)
Set rngC = Worksheets(ksWSChanges).Range(ksChanges)
With rngC
If .Rows.Count > 1 Then
Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
Range(.Rows(2), .Rows(.Rows.Count)).Font.ColorIndex = xlColorIndexAutomatic
Range(.Rows(2), .Rows(.Rows.Count)).Font.Bold = False
End If
End With
'
' process
lChanges = 1
' 1st pass: updates & deletions
With rngOK
For I = 5 To .Rows.Count
Set c = rngUK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' deletion
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksRemove
For J = 1 To rngO.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbRed
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
Else
bEqual = True
lRow = c.Row - rngUK.Row + 1
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value <> rngU.Cells(lRow, J).Value Then
bEqual = False
Exit For
End If
Next J
If Not bEqual Then
' change
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksChange
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value = rngU.Cells(lRow, J).Value Then
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
Else
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbMagenta
rngC.Cells(lChanges, J + 1).Font.Bold = True
End If
Next J
End If
End If
Next I
End With
' 2nd pass: additions
With rngUK
For I = 5 To .Rows.Count
Set c = rngOK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' addition
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksAdd
For J = 1 To rngU.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbBlue
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
End If
Next I
End With
'
' end
Worksheets(ksWSChanges).Activate
rngC.Cells(2, 3).Select
Set rngC = Nothing
Set rngUK = Nothing
Set rngU = Nothing
Set rngOK = Nothing
Set rngO = Nothing
Beep
'
End Sub
此按钮代码会将更新应用于标记为“更改”和“添加”的行（我不关心删除）
Sub Update()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Application.ScreenUpdating = False
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL")
Set sh2 = ActiveWorkbook.Worksheets("CHANGES")
lastRow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Get last row for both sheets
lastRow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row ' searching both
For s2Row = 2 To lastRow2 'Loop through "CHANGES"
If sh2.Cells(s2Row, 1).Value = "CHANGE" Then
tempName = sh2.Cells(s2Row, 2).Value 'extra step for understanding concept
'There is a match, so now
For s1Row = 2 To lastRow1 'Search through the other sheet
If sh1.Cells(s1Row, 1).Value = tempName Then
For I = 2 To 35
sh1.Cells(s1Row, I).Value = sh2.Cells(s2Row, I + 1).Value 'Copy Values
Next I
End If
Next s1Row
End If
Next s2Row
For s2Row = 2 To lastRow2
If sh2.Cells(s2Row, 1).Value = "ADD" Then
sh2.Range("B" & s2Row & ":BB" & s2Row).Copy 'Copy rows
sh1.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(lastRow1 + 1, 78).Value = "ADD" 'Classify the row as newly added
End If
Next s2Row
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
此按钮将对现有UniqueIDs更改的PL单元格值应用更新
Sub Update_PL()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
'No Longer requires clearing screen, we will match unique ids and update/add as necessary
'ThisWorkbook.Sheets("ORIGINAL").Rows("5:65536").ClearContents 'clear
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
Set sh2 = ws 'Selects Active Sheet
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 2 To lastRow2 'Loop through Active WorkSheet
tempName = sh1.Cells(s2Row, 1).Value 'Define UniqueID to loop
tempPL = sh1.Cells(s2Row, 22).Value 'Define PL to loop
For s1Row = 2 To lastRow1 'Match UniqueIDs between Master sheet and Active Sheet
If ActiveSheet.Cells(s1Row, 1).Value = tempName Then 'If Matches TRUE then
For I = 2 To 35 'Loop all Columns and update as necessary
ActiveSheet.Cells(s1Row, I).Value = sh1.Cells(s2Row, I).Value 'Copy Values
Next I
End If
Next s1Row
Next s2Row
'copy data from individual sheets
'Range("A2", Range("AB65536").End(xlUp)).Copy lastRng
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
最后一个按钮用于将新的UniqueID添加到相应的PL
Sub Add_Rows()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet
Dim tempPL As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 5 To lastRow2 'Loop through Active WorkSheet
If sh1.Cells(s2Row, 78).Value = "ADD" Then
tempPL = sh1.Cells(s2Row, 23).Value
If ActiveSheet.Name = tempPL Then
sh1.Range("A" & s2Row & ":AB" & s2Row).Copy 'Copy rows
ActiveSheet.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(s2Row, 78).Value = "ADDED" 'Validate Row has been added in Master Sheet
End If
End If
Next s2Row
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True 'Resume ScreenUpdating
Sheets("ORIGINAL").Activate 'Display Original Sheet
End Sub
复杂？是的......但解决了我的问题。
BR！涡