PDA

View Full Version : [SOLVED] VBA - Copy with validatation



Shywawa
02-20-2018, 04:42 AM
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
02-20-2018, 05:32 AM
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
02-20-2018, 06:30 AM
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
02-20-2018, 07:30 AM
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
02-20-2018, 07:53 AM
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
02-20-2018, 08:19 AM
Perfect!

:bow:

Thank you very much!

Shywawa
02-20-2018, 08:21 AM
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
02-21-2018, 12:59 AM
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: