Question

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

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
Coubourn, Stephen|A|201|Q4hours
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours

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

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

Answer 1

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

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

更改代码，使其不会填充更多单元格，只需替换更改

1 个答案: