更改代码，使其不填充更多的单元格，只是替换为更改 [英] Change code so that it doesnt populate more cells, just replaces with changes

问题描述

我使用的代码是根据主列表中D列中的内容填充表。每次运行代码时，它会重新添加单元格，而不是仅更新以反映主列表。我很难描述这个，所以我举一个例子。

This code that I'm using to populate sheets based off of what is in Column D in the master list. Every time I run the code it re adds the cells rather than just update to reflect the master list. I'm having a hard time describing this so I'll give an example.

Coubourn, Stephen|A|201|Q4hours    
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours

这些是唯一应该填充表单的，基于主表中的内容。但是，如果我再次运行代码，它将加倍它看起来像这样：

These are the only ones that should populate the sheet, based off of what is in the Master sheet. However if I run the code another, it will double it to look like this:

Coubourn, Stephen|A|201|Q4hours
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours
Coubourn, Stephen|A|201|Q4hours
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours

如何防止翻倍我只想让它反映在主表上。以下是我正在使用的代码。

How do I prevent it from doubling up? I just want it to reflect what it on the Master sheet. Below is the code I am using.

Sub TestRevised()

    Dim cell As Range
    Dim cmt As Comment
    Dim bolFound As Boolean
    Dim sheetNames() As String
    Dim lngItem As Long, lngLastRow As Long
    Dim sht As Worksheet, shtMaster As Worksheet

    'Set master sheet
    Set shtMaster = ThisWorkbook.Worksheets("Master Vitals Data")

    'Get the names for all other sheets
    ReDim sheetNames(0)
    For Each sht In ThisWorkbook.Worksheets
        If sht.Name <> shtMaster.Name Then
            sheetNames(UBound(sheetNames)) = sht.Name
            ReDim Preserve sheetNames(UBound(sheetNames) + 1)
        End If
    Next sht
    ReDim Preserve sheetNames(UBound(sheetNames) - 1)

    For Each cell In shtMaster.Range("D1:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row)
        bolFound = False
        For lngItem = LBound(sheetNames) To UBound(sheetNames)
            If cell.Value2 = sheetNames(lngItem) Then
                bolFound = True
                Set sht = ThisWorkbook.Worksheets(sheetNames(lngItem))
                On Error GoTo SetFirst
                lngLastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
                On Error GoTo 0
                shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(lngLastRow, 1)
            End If
        Next lngItem
        If bolFound = False Then
            For Each cmt In shtMaster.Comments
                If cmt.Parent.Address = cell.Address Then cmt.Delete
            Next cmt
            cell.AddComment "no sheet found for this row"
            ActiveSheet.EnableCalculation = False
    ActiveSheet.EnableCalculation = True
        End If
    Next

    Exit Sub

    SetFirst:
        lngLastRow = 1
        Resume Next

End Sub

推荐答案

请参阅下面编辑的代码的相关部分（说明在代码注释中）：

See the relevant part of your code I've edited below (explanation are inside the code comments):

Dim MatchRow As Variant

For Each cell In shtMaster.Range("D1:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row)
    bolFound = False

    ' instead of looping through the array of sheets >> use Application.Match
    If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
        bolFound = True
        Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))

        ' now use a 2nd Match, to find matches in Unique column "A"
        MatchRow = Application.Match(cell.Offset(, -3).Value, sht.Range("A:A"), 0)
        If Not IsError(MatchRow) Then
            shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(MatchRow, 1)
        Else '<-- no match in sheet, add the record at the end
            On Error GoTo SetFirst
            lngLastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            On Error GoTo 0
            shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(lngLastRow, 1)
        End If

    End If

    If bolFound = False Then
        For Each cmt In shtMaster.Comments
            If cmt.Parent.Address = cell.Address Then cmt.Delete
        Next cmt
        cell.AddComment "no sheet found for this row"
        ActiveSheet.EnableCalculation = False
        ActiveSheet.EnableCalculation = True
    End If

    Set sht = Nothing
Next

这篇关于更改代码，使其不填充更多的单元格，只是替换为更改的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！