Exception to remove duplicates function

Hello,

I need a exception code for not deleting below content of my packing list.

Let me be clear I wrote below function to clear all unwanted duplicated from my packing list. Unfortunately, some parts has same content as Gross weight and Net weight which below code consider as duplicates and delete it off.

I want some code exception to surpass this content alone. Enclosed spreadsheet which has gross weight content which starts with lots of space as it's imported from a text file.

Need your support please


Sub DeleteRows()

Range("A1").Select
    ActiveSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

Hi,

Can we make a condition if A column cell starts with Character 32 which is space it should not delete duplicates. I dont know how to compile in code. Can anyone support please?

If Left(C, 1) = Chr(32)

Please attach a file that has more data and then explain in detail what you want to do referring to specific cells, rows and columns. It would help if you could include a sheet that contains the expected results after running the macro.

Try this on a copy of your file:

Sub DeleteDuplicates()
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Application
        ' Turn off screen updating to increase performance
        .ScreenUpdating = False
        Dim LastColumn As Integer
        LastColumn = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
        With Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
            ' Use AdvanceFilter to filter unique values
            .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
            .SpecialCells(xlCellTypeVisible).Offset(0, LastColumn - 1).Value = 1
            On Error Resume Next
            ActiveSheet.ShowAllData
            Range("A1:B" & LastRow).AutoFilter Field:=1, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
            Range("B1:B" & LastRow).SpecialCells(xlCellTypeVisible) = 1
            ActiveSheet.ShowAllData
            'Delete the blank rows
            Columns(LastColumn).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Err.Clear
        End With
        'Columns(LastColumn).Clear
        .ScreenUpdating = True
    End With
End Sub

Try this version:

Sub DeleteDuplicates()
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Application
        ' Turn off screen updating to increase performance
        .ScreenUpdating = False
        Dim LastColumn As Integer
        LastColumn = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
        With Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
            ' Use AdvanceFilter to filter unique values
            .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
            .SpecialCells(xlCellTypeVisible).Offset(0, LastColumn - 1).Value = 1
            On Error Resume Next
            ActiveSheet.ShowAllData
            Range("A1:B" & LastRow).AutoFilter Field:=1, Criteria1:="=Gross Weight*"
            Range("B1:B" & LastRow).SpecialCells(xlCellTypeVisible) = 1
            ActiveSheet.ShowAllData
            'Delete the blank rows
            Columns(LastColumn).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            Err.Clear
        End With
        Columns(LastColumn).Clear
        .ScreenUpdating = True
    End With
End Sub

Column B which is a helper column will be cleared.

Can you post the macro you run to upload packing list text file?

Try:

Sub ImportPackinglistTextFile()
    Dim Textfile As Workbook
    Dim openfiles() As Variant
    Dim i As Integer
    openfiles = Application.GetOpenFilename(Title:="Select File(s) to Import", MultiSelect:=True)
    Application.ScreenUpdating = False
    For i = 1 To Application.CountA(openfiles)
        Set Textfile = Workbooks.Open(openfiles(i))
        Textfile.Sheets(1).UsedRange.Copy
        Workbooks(1).Activate
        Workbooks(1).Worksheets.Add
        ActiveSheet.Paste
        ActiveSheet.Name = Textfile.Name
        ActiveSheet.Copy
        ActiveWorkbook.SaveAs Filename:="C:\Users\Desktop\Packing list\" & ActiveSheet.Name & ".xlsx", FileFormat:=51
        Textfile.Close
    Next i
    Application.ScreenUpdating = True
End Sub

@ Mumps1

Few things, I need to copy and save macro file only after it runs. So I added this code to compiled one

Few things causing issue,

One - It is copying sheet 1 as well and saving it in location. I dont want to consider sheet 1 which is empty

Two - New work books added is not closing. I want to get it saved in specific location thats it - I added code close active work book

Three - Active sheet which is being copied is not deleting once pasted

Sub RunPackinglist()
    MsgBox "Please upload Packinglist(s) .Txt file"
    Call ImportPackinglistTextFile
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    For Each ws In Sheets
    ws.Activate
        If ws.Name <> "Sheet1" Then
        Call Packinglist_Compilation
        End If
        ActiveSheet.Copy
        ActiveWorkbook.SaveAs Filename:="C:\Users\elumap2\Desktop\Packing list\" & ActiveSheet.Name & ".xlsx", FileFormat:=51
    Next ws
    
    Application.ScreenUpdating = True

End Sub

Please post the ImportPackinglistTextFile macro. You want to loop through all the sheets in the Packinglist(s) file, ignoring "Sheet1". Then you want to copy each sheet to a new workbook and save the new workbook, close the new workbook and delete the copied sheet in the Packinglist(s) file. This this correct?