Excel VBA – 使用if和countif清除（不删除）重复单元格的第一项

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

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

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

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

将报表中的数据复制到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 

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

Answer 1

下面的VBA代码将为您工作，testing和工作

 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

在将数据复制到新工作表之前，您可能会发现删除重复项更容易（也更快捷）。 如果将它读入一个数组中，将所有的模式都改为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