Question

我正在尝试编写一个VBA脚本，它将两个工作表合并在一起，然后删除所有符合特定条件的重复项。首先，它仅删除重复的条目，并且在E列和F列中没有数据。我认为我的代码最有效，除了它包括它试图在COUNTIF搜索中查找的单元格外，因此它总是返回值。 1.我想在范围内进行countif搜索，并在for循环中排除当前单元格。我完全同意重新设计for循环的想法，如果有更简单的方法，它可以删除重复项。

谢谢！

Public Sub HMBMerge()

Dim sheet1 As String
Dim sheet2 As String
Dim comp1 As String
Dim comp2 As String
Dim sheet1Len As Long
Dim sheet2Len As Long
Dim t As Long
Dim cell As Range
Dim mergeRange As Range

sheet1 = Application.InputBox("Type name of sheet 1", "Sheet 1", , , , , , 2)
sheet2 = Application.InputBox("Type name of sheet 2", "Sheet 2", , , , , , 2)
HMBmergename = Application.InputBox("Type name of merged output sheet name", "Output Sheet Name", , , , , , 2)

Application.ScreenUpdating = False

Worksheets(sheet1).Activate
sheet1Len = Worksheets(sheet1).Range("B1", Range("B1").End

(xlDown)).Rows.Count

    Worksheets(sheet2).Activate
    sheet2Len = Worksheets(sheet2).Range("B1", Range("B1").End(xlDown)).Rows.Count

    ThisWorkbook.Sheets.Add.Name = HMBmergename

    Worksheets(sheet1).Activate
    ActiveWorkbook.Worksheets(sheet1).Range("A1", Range("I1").End(xlDown).Offset(0, 1)).Copy Destination:=Worksheets(HMBmergename).Range("A1")
    Worksheets(sheet2).Activate
    ActiveWorkbook.Worksheets(sheet2).Range("A1", Range("I2").End(xlDown).Offset(0, 1)).Offset(1, 0).Copy Destination:=Worksheets(HMBmergename).Cells(sheet1Len + 1, 1)

    ThisWorkbook.Worksheets(HMBmergename).Activate
    ThisWorkbook.Worksheets(HMBmergename).Columns("A:J").AutoFit
    Worksheets(HMBmergename).Range("A1", Range("I1").End(xlDown).Offset(0, 1)).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes


    For t = Worksheets(HMBmergename).Range("B1", Range("B1").End(xlDown)).Rows.Count To 1 Step -1
        If Application.WorksheetFunction.CountIf(Worksheets(HMBmergename).Range("B1", Range("B1").End(xlDown)), ThisWorkbook.Worksheets(HMBmergename).Cells(t, "B").Value) > 0 And Worksheets(HMBmergename).Cells(t, "E") = "" And Worksheets(HMBmergename).Cells(t, "F") = "" Then
            MsgBox Application.WorksheetFunction.CountIf(Worksheets(HMBmergename).Range("B1", Range("B1").End(xlDown)), ThisWorkbook.Worksheets(HMBmergename).Cells(t, "B").Value)
            Worksheets(HMBmergename).Rows(t).EntireRow.Delete
        End If
    Next

    End Sub

Answer 1

我知道它不是最漂亮的（但是再次，这是第一次VBA项目所期望的），但是我通过编写两个if语句解决了问题。一个检查空白，然后检查是否重复。

For t = Worksheets(HMBmergename).Range("B1", Range("B1").End(xlDown)).Rows.Count To 1 Step -1
    If Worksheets(HMBmergename).Cells(t, "E") = "" And Worksheets(HMBmergename).Cells(t, "F") = "" Then
        If Application.WorksheetFunction.CountIf(Worksheets(HMBmergename).Range("B1", Range("B1").End(xlDown)), ThisWorkbook.Worksheets(HMBmergename).Cells(t, "B").Value) > 1 Then
            'MsgBox Application.WorksheetFunction.CountIf(Worksheets(HMBmergename).Range("B1", Range("B1").End(xlDown)), ThisWorkbook.Worksheets(HMBmergename).Cells(t, "B").Value)
            Worksheets(HMBmergename).Rows(t).EntireRow.Delete
        End If
    End If
Next

在搜索中初始化自己的单元格时查找并删除满足多个条件的重复项

1 个答案: