Home Excel VBA - use the if and countif to clear(not delete) the duplicate cell expect the first item
Reply: 2

Excel VBA - use the if and countif to clear(not delete) the duplicate cell expect the first item

user3472143 Published in 2017-12-07 16:21:55Z

I have two workbooks. one is report.xls, another one is AT.xlsm.

In report.xls, there has the sheet called "Service".

In AT.xlsm, there has the sheet called "Worksheet".

Thanks for the help of @mooseman, it can use the VBA to copy the column B,C,F,J,E,D expect first row of report to the column A,C,D,E,F,H of AT.

After copy the data from the report to AT, i want to remove the duplicate cell(just clear the content of the cell) expect the first item that use the VBA. I know that use the if and countif can work out.

Would you please tell me how to use the if and countif in the VBA to remove the duplicate cell(just clear the content of the cell) expect the first item ?

Thank you very much.

 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

Updated: @ Maldred The result is partly worked, it can some clear the content of some duplicate.

Maldred Reply to 2017-12-07 17:28:39Z

The below VBA code will work for you, tested and working

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
   End With

End Sub

Please ask if you have questions or issues using it

Ambie Reply to 2017-12-08 03:57:55Z

You might find it's easier (and quicker) to remove the duplicates before you copy the data to the new sheet. If you read it into an array, changed all dupes to Empty and then wrote the array to the worksheet, you wouldn't need that second task of emptying cells:

'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
            'Keep it - it's a first instance.
            uniques.Add True, CStr(data(r, 1))
        End If

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

You need to login account before you can post.

About| Privacy statement| Terms of Service| Advertising| Contact us| Help| Sitemap|
Processed in 0.384094 second(s) , Gzip On .

© 2016 Powered by mzan.com design MATCHINFO