基于唯一标识符列比较两个工作表之间的所有列，如果存在差异，则更新Sheet1行-Java 学习之路

-1

我有一个工作簿，其中包含2个工作表和子工作表，按产品系列列命名：

新数据表
主表单（"DBQ Query Result"）
子板（钻探和修井，钓鱼，班轮系统，专业服务，井筒清洁）

它们都有相同的 Headers ，在列 Headers 中有一个uniqueID列 .

A部分

我想在这两张纸之间匹配uniqueID并且：

当匹配时，比较每列的行单元格值并更新是否存在差异
当主数据表中不存在NEW DATA表中的唯一ID时，我希望将与此uniqueId关联的整行复制到主表表

第B部分

我希望有一个新按钮，按下时，Master Page中的UniqueID将与每个子表的Unique Id列进行比较，并且：

当匹配时，根据UNIQUEID更新子表行
当没有匹配时，这意味着创建了一个新的UNIQUEID，这应该作为最后一行添加到相应的子表中

我想用VBA宏来完成上面的事情 . 我附上了excel https://dl.dropboxusercontent.com/u/29585269/Sample.xlsx的样本 .

如果您需要任何其他信息，请与我们联系 .

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

此按钮将对现有UniqueID更改的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

最后一个按钮用于向对应的PL添加新的UniqueID

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！涡流

回复于 2024-04-26T04:30:59+08:00

基于唯一标识符列比较两个工作表之间的所有列，如果存在差异，则更新Sheet1行

A部分

第B部分

1 回答

相关问题