VBA - Copy with validatation

[Shywawa]

Hi Guys,

I want to copy all the unique values from a column in Sheet 2 to a column in sheet1.

I think I am almost there as the validation seems to work just fine but the result is only posted in the first cell of the range. I'm probably mixing some range and cells functions.

Here is the code i wrote so far.

Will add another IF to check for unique values later on. Just want to solve this Copy issue first.

Sub Import_data()

    
    Dim cell As Range, Target As Range, CheckCells As Range
    
    

 
 Set CheckCells = Sheet2.Range("C2:C" & Sheet2.Range("C" & Rows.Count).End(xlUp).Row).Cells
 Set Target = Sheet1.Range("E31:E" & Sheet1.Range("E" & Rows.Count).End(xlUp).Row).Cells
 


For Each cell In CheckCells
   
        If cell.Value > 1 Then
          
   Cells(Target.Row, 5) = Sheet2.Cells(cell.Row, 3)
         
 End If
                 
Next cell

  
End Sub

Kind regards,
Shywawa

[p45cal]

This is very likely possible with one or two lines of code (Advanced filter), but it is very difficult to gauge what you want from your snippet of code.
What you need to do is:
Supply a file with realistic data (not pictures).
Show somewhere expected results.
Explain in words what you're trying to achieve.

[Shywawa]

Hi Pascal,

Attached below:

Example.xlsm


What I want my macro to do (in the end) is to open a file or take the information from another sheet (let's stick with Sheet for now) and add all the new/unique part numbers from the sheet (All Parts) to the existent parts in my file (Main Page).

The extra validation i was working on and wanted to include was to add only the parts that are new and not Damaged (column C All Pars sheet).

Let me know if you want more details.


Kind regards,
Shywawa

[p45cal]

Try:

Sub blah()
With Sheet2
  Set SourceRng = .Range(.Range("A2"), .Cells(.Rows.Count, "C").End(xlUp))
End With
With Sheet1
  Set Destn = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
  Set ExistingPartNoRng = .Range(.Cells(7, "D"), Destn.Offset(-1, 3))
End With
For Each rw In SourceRng.Rows
  If rw.Cells(3) = "NO" Then
    If IsError(Application.Match(rw.Cells(2), ExistingPartNoRng, 0)) Then    'if unique?
      Destn.Value = rw.Cells(1).Value    'copy index no.
      Destn.Offset(, 3).Value = rw.Cells(2).Value    'copy part no.
      Set Destn = Destn.Offset(1)    'update destination to next row down.
      Set ExistingPartNoRng = ExistingPartNoRng.Resize(ExistingPartNoRng.Rows.Count + 1)    'update existing numbers range by adding bottomost cell.
    End If
  End If
Next rw
End Sub

[p45cal]

or:

Sub blah2()
With Sheet1
  Set Destn = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
  With Sheet2
    .Range("B1").AutoFilter Field:=3, Criteria1:="NO"
    Set AFRng = Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(1))    'just thte data body part (excludes headers).
  End With    'Sheet2
  With AFRng
    Intersect(.SpecialCells(xlCellTypeVisible), .Columns(1)).Copy Destn
    Intersect(.SpecialCells(xlCellTypeVisible), .Columns(2)).Copy Destn.Offset(, 3)
  End With    'AFRng
  .Range("A6:D" & .Cells(.Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=4, Header:=xlYes
End With    'Sheet1
Sheet2.Range("B1").AutoFilter    'remove Autofilter.
End Sub

[Shywawa]

Perfect!



Thank you very much!

[Shywawa]

I only tried the first version, will give the second one a try tomorrow morning and let you know how it goes.

Thank you again!

Kind regards,
Shywawa

[Shywawa]

I tried the second version too. Works ok but i like the first one better as i can add some more conditions and ranges (in a fashion i am more accustomed with - if ,like, and).


Thank very much for the help!