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. :banghead:


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:

21667


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!

:bow:

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!

:bow: