Excel VBA - 使用if和countif清除（不删除）期望第一个项目的重复单元格

Question

我有两本工作簿。一个是report.xls，另一个是AT.xlsm。

在report.xls中，有一个名为“Service”的工作表。

在AT.xlsm中，有一个名为“Worksheet”的工作表。

感谢@mooseman的帮助，它可以使用VBA将列B，C，F，J，E，D复制到第一行报告到A，C，D，E，F，H列AT。

将数据从报告复制到AT后，我想删除重复的单元格（只清除单元格的内容），期望第一个使用VBA的项目。我知道使用if和countif可以解决问题。

请您告诉我如何使用VBA中的if和countif删除重复的单元格（只清除单元格的内容），期望第一项？

非常感谢。

 Sub add_click()

Dim sDirectory As String
Dim sFilename As String
Dim sheet As Worksheet
Dim total As Integer
Dim lastRow As Long
Dim sImportFile As String
Dim totalactive As Integer
Dim readsheetName As String
Dim destsheetName As String

readsheetName = "Service"
destsheetName = "Worksheet"

addWSn = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sDirectory = ActiveWorkbook.Path
sFilename = sDirectory + "\*.xl??"

sImportFile = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open report")
If sImportFile = "False" Then
    MsgBox ("No File")
    Exit Sub
End If

'set destination workbook and worksheet
Set wb2 = ThisWorkbook
Set wsw = wb2.Sheets(destsheetName)
lastRow = wsw.Cells(wsw.Rows.Count, "D").End(xlUp).Row
lastRow = lastRow + 2
Set wb = Workbooks.Open(sImportFile)
Set wss = wb.Sheets(readsheetName)

wss.Range(wss.Cells(2, 2), wss.Cells(wss.Range("B" & wss.Rows.Count).End(xlUp).Row, 2)).Copy
wsw.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues

wss.Range(wss.Cells(2, 3), wss.Cells(wss.Range("C" & wss.Rows.Count).End(xlUp).Row, 3)).Copy
wsw.Cells(lastRow, 3).PasteSpecial Paste:=xlPasteValues

wss.Range(wss.Cells(2, 6), wss.Cells(wss.Range("F" & wss.Rows.Count).End(xlUp).Row, 6)).Copy
wsw.Cells(lastRow, 4).PasteSpecial Paste:=xlPasteValues

wss.Range(wss.Cells(2, 10), wss.Cells(wss.Range("J" & wss.Rows.Count).End(xlUp).Row, 10)).Copy
wsw.Cells(lastRow, 5).PasteSpecial Paste:=xlPasteValues

wss.Range(wss.Cells(2, 5), wss.Cells(wss.Range("E" & wss.Rows.Count).End(xlUp).Row, 5)).Copy
wsw.Cells(lastRow, 6).PasteSpecial Paste:=xlPasteValues

wss.Range(wss.Cells(2, 4), wss.Cells(wss.Range("D" & wss.Rows.Count).End(xlUp).Row, 4)).Copy
wsw.Cells(lastRow, 8).PasteSpecial Paste:=xlPasteValues

wsw.Range(wsw.Cells(lastRow, 6), wsw.Cells(wsw.Range("F" & wsw.Rows.Count).End(xlUp).Row, 6)).Replace What:="[S]", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
wsw.Columns("E:K").HorizontalAlignment = xlRight

'close excel file
Workbooks.Open (sImportFile)
ActiveWorkbook.Close SaveChanges:=False
End Sub

更新： @Malderred 结果部分工作，它可以清楚一些重复的内容。

Answer 1

以下VBA代码适合您，经过测试和使用

Sub RemoveItems()

   Dim i As Long
   ' Starting on second line
   i = 2
   With ActiveSheet
      Do While (Not (.Range("A" & i).Value = ""))
      Debug.Print .Range("A" & i).Value
         If (.Range("A" & i).Value = .Range("A" & (i - 1)).Value) Then
            .Range("A" & i).ClearContents
         End If
         ' Increment the loop
         i = i + 1
      Loop
   End With

End Sub

请询问您是否有使用它的问题或问题

Answer 2

在将数据复制到新工作表之前，您可能会发现删除重复项更容易（也更快）。如果你把它读成数组，把所有的dupes都改成Empty，然后将数组写入工作表，你就不需要第二个清空单元格的任务了：

'Additonal declarations
Dim data As Variant, readCols As Variant, destCols As Variant
Dim exists As Boolean
Dim i As Long, r As Long
Dim uniques As Collection

'... your code to initialise worksheets, etc.

lastRow = wsw.Cells(wsw.Rows.Count, "D").End(xlUp).Offset(2).Row

'Define column maps
readCols = Array("B", "C", "F", "J", "E", "D")
destCols = Array("A", "C", "D", "E", "F", "H")

For i = LBound(readCols) To UBound(readCols)
    'Read the data.
    With wss
        data = .Range(.Cells(2, readCols(i)), .Cells(.Rows.Count, readCols(i)).End(xlUp)).Value2
    End With

    'Check for duplicates.
    Set uniques = New Collection
    For r = 1 To UBound(data, 1)
        exists = False: On Error Resume Next
        exists = uniques(CStr(data(r, 1))): On Error GoTo 0
        If exists Then
            'Reomve the duplicate.
            data(r, 1) = Empty
        Else
            'Keep it - it's a first instance.
            uniques.Add True, CStr(data(r, 1))
        End If
    Next

    'Write the data
    wsw.Cells(lastRow, destCols(i)).Resize(UBound(data, 1), 1).Value = data

Next