Delete duplications when Importing

[themluis]

Hey guys so I'm doing this code for the company where I work as a internship. I did some part of it with the help of people from this forum and others but the code is big and I cannot find a place or the piece of code needed to do what I asked for, and that fits my code I'm newbie by the way.

So I will explain the code IT will import from a target excel file and then paste in my main file, after that it will search in the main file for the data that is present in the column A and then copy the information that is linked to the names and paste it in the import sheet called (Status) so I wanted to put a delete duplications before searching the information in the main file.

Sorry for the Big code. Forgot to mentioned the files come duplicated from the source file but I cannot change the source file, probably is easier if the import doesn't take duplicated rows ?

    Sub ImportData()
    Application.ScreenUpdating = False
    Dim Path As String, Lstrw As Long
    Dim SourceWb As Workbook
    Dim TargetWb As Workbook

    Path = "C:\Users\DZPH8SH\Desktop\Status 496 800 semana 12 2015.xls"    'Change this to your company workbook path
    workbook path
    Set SourceWb = Workbooks.Open(Path)
    Set TargetWb = ThisWorkbook

    Dim n As Integer, targetRow As Long
    targetRow = 3

    With SourceWb.Sheets(1)
    Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    .Range("M1:M" & Lstrw).AutoFilter Field:=1, Criteria1:="496"
    .Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
    TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
    .ShowAllData
    End With

    With SourceWb.Sheets(2)
    Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    .Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
    TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
    End With

    SourceWb.Close savechanges:=False
    Application.ScreenUpdating = True

    '====================================== Search in the main file code below 
    
    On Error Resume Next

    Dim CurrWk As Worksheet
    Dim wb As Workbook
    Dim wk As Worksheet
    Dim LRow As Integer
    Dim myLRow As Integer
    Dim myLCol As Integer
    Dim F1 As Boolean
    Dim f As Boolean

    Set wb = ActiveWorkbook
    Set CurrWk = wb.Sheets(7)

    LRow = LastRow(CurrWk)

    For r = 3 To LRow
        
    f = False

    For Each wk In wb.Worksheets
    
        If wk.Name = "Status" Or wk.Name = "Gráfico_2015" Then GoTo abc 'Exit For
        If wk.Visible = xlSheetHidden Then GoTo abc 'Exit For
        
        myLRow = LastRow(wk)
        myLCol = LastCol(wk)
        
        For r1 = 3 To myLRow
            For c1 = 1 To myLCol
                If Trim(CurrWk.Cells(r, 1).Value) = Trim(wk.Cells(r1, c1).Value) Then
                    f = True
                    F1 = False
                    If wk.Name = "ÄA" Then
                        For I = 12 To 18
                            If wk.Cells(r1, I).Value = 1 Then
                                CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
                                F1 = True
                                Exit For
                            End If
                        Next I
                    Else
                        For I = 14 To 20
                            If wk.Cells(r1, I).Value = 1 Then
                                CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
                                F1 = True
                                Exit For
                            End If
                        Next I
                    End If
                    If F1 = False Then CurrWk.Cells(r, 6).Value = "Set de equipa diferente"
                End If
            Next c1
        Next r1
        'If f = True Then Exit For
    abc:
    Next wk
    
    If f = False Then
        CurrWk.Cells(r, 12).Value = "Não está presente no ficheiro"
    End If
    
    Next r

    Set wk = Nothing
    Set wb = Nothing

    On Error GoTo 0

    MsgBox "Finished"

    End Sub
    Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
    End Function

    Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
    End Function

 

[jbeaucaire]

Crossposted: Delete duplications when Importing

 

[Joe4]

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule #10 here: Forum Rules).

This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

For a more complete explanation on cross-posting, see here: Excelguru Help Site - A message to forum cross posters).

 

[themluis]

sorry It was my bad didn't know about this rule, I wa thinking that I could post in another forum to see If someone helped me, because to me this is a hard question, again sorry.

 

[Joe4]

I wa thinking that I could post in another forum

You can, we do allow it here, provided you mention that you are Cross-Posting and provide links to the other threads you have on the other forums.

 

[themluis]

In terms of my problem I need to integrate the code to delete duplications with the current done code.

 

[themluis]

IF I add this to my code

Cells.RemoveDuplicates Columns:=Array(1)

It always delete my color format.