Please look at the attached image
This is just dummy data.
My requirement is

If Internal Asset ID (Column B) is unique, Copy row regardless selected or not (Column F).

If Internal Asset ID not unique i.e. same Internal Asset ID is present column B
more than once, see against which Internal Asset ID is Column F marked as selected & then copy only that row. 
Copied rows are: 3rd row,5th row, 7th, 8th, 9th row”
This data is in Workbook1:Sheet1 and I have to copy it to Workbook2:Sheet2 The mapping of copy & paste has to be like mentioned below –
WB1:Sheet1 A to WB2:Sheet2 A
WB1:Sheet1 B to WB2:Sheet2 B
WB1:Sheet1 N to WB2:Sheet2 C
WB1:Sheet1 X to WB2:Sheet2 D
WB1:Sheet1 Y to WB2:Sheet2 E
WB1:Sheet1 AY to WB2:Sheet2 G
WB1:Sheet1 C to WB2:Sheet2 H
WB1:Sheet1 D to WB2:Sheet2 I
WB1:Sheet1 E to WB2:Sheet2 J
WB1:Sheet1 F to WB2:Sheet2 K
WB1:Sheet1 BI to WB2:Sheet2 R
WB1:Sheet1 AT to WB2:Sheet2 S
WB1:Sheet1 AU to WB2:Sheet2 T
WB1:Sheet1 AV to WB2:Sheet2 U
WB1:Sheet1 AW to WB2:Sheet2 V
The pasting in Workbook2:Sheet2 has to start from “A12”
My attempt:
Sub cpyCol()
Dim wc As Worksheet, wa As Worksheet
Dim lr As Long, I As Long, J As Long
Dim uR As Range
Dim eNumStorage() As String ' initial storage array to take values
Dim x As String
Set wc = Sheets("Test")
Set wa = Sheets("Test")
lr = wc.Range("A" & Rows.Count).End(xlUp).Row
ReDim eNumStorage(1 To lr  2)
Application.ScreenUpdating = False
For I = 3 To lr 'sheets all have headers that are 2 rows
If (Not IsEmpty(Cells(I, 2).Value)) Then ' checks to make sure the value isn't empty
J = J + 1
eNumStorage(J) = Cells(I, 2).Value ' to store values of internal Asset ID in an array
End If
If wc.Range("F" & I) = "Selected" Then 'check if column F is marked as selected
If (uR Is Nothing) Then
Set uR = Range(I & ":" & I)
Else
Set uR = Union(uR, Range(I & ":" & I))
End If
End If
Next I
uR.copy Destination:=wa.Range("A13")
Application.ScreenUpdating = True
End Sub
Result (For testing I just tried copying & pasting from the same sheet to the same sheet)
 I am able to copy rows which are marked as selected in column F
 I am able to store the values of Internal Asset ID in column B in array eNumStorage()
 So I am able to copy 3rd and 5th row
Where I need help –
 Not able to copy 7th,8th and 9th row.
What I tried to copy 7th,8th and 9th row
If eNumStorage(J) = eNumStorage(J + 1) Then
If wc.Range("F" & I) = "Selected" Then 'check if column F is marked as selected
If (uR Is Nothing) Then
Set uR = Range(I & ":" & I)
Else
Set uR = Union(uR, Range(I & ":" & I))
End If
End If
End If
Issue –
Not working for later rows
Any help would be much appreciated. Thanks.
To determine which line has to be copied and which not you can use this formula
in column G
=IF(AND(COUNTIF(B:B,B:B)>1,COUNTIFS(B:B,B:B,F:F,"Selected")=1,F:F<>"Selected"),"","copy")
Now you could even use filters to filter by column G.
Explanation

COUNTIF(B:B,B:B)
counts the occurrences of the “AssetID”. So this is a test for uniqueness if it is>1
the ID is not unique. 
COUNTIFS(B:B,B:B,F:F,"Selected")
counts the occurrences of nonunique “AssedIDs” that are “Selected”. So if this is=1
it means one of the IDs was marked as selected. 
F:F<>"Selected"
means the ID was not selected
In total the formula means: Mark all IDs as Copy
but sort out these which are …
 not unique
 AND not unique and not selected
 AND not selected
and this basically means, keep all marked as copy which are:
 unique
 OR nonunique and selected
 OR selected
Or an example with VBA
using pretty much the same formula.
Sub Example()
Dim ws As Worksheet
Set ws = Worksheets("Tabelle3") 'your worksheet
Dim lRow As Long 'last used row
lRow = ws.Cells(ws.Cells.Rows.Count, "A").End(xlUp).Row
Const fRow As Long = 3 'first row with data
Dim i As Long
For i = fRow To lRow 'run from first data row to last
If Not (Application.WorksheetFunction.CountIf(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & i)) > 1 And _
Application.WorksheetFunction.CountIfs(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & i), ws.Range("F" & fRow, "F" & lRow), "Selected") = 1 And _
ws.Range("F" & i) <> "Selected") Then
'copy this line
End If
Next i
End Sub
Answer：
Alright I figured out a solution that does exactly what I wanted. Thank you @PEH for your help.
Sub cpyCol()
Dim wc As Worksheet, wa As Worksheet
Dim lr As Long, I As Long, J As Long, I2 As Long
Dim uR As Range
Dim wb, wb1 As Workbook
Dim eNumStorage() As String ' initial storage array to take values
Set wb = Workbooks.Open("C:\Users\Z003U8UC\Downloads\PP_Anan.xlsm")
Set wb1 = ThisWorkbook
Set ws = wb.Sheets("Procurement plan PM80 >")
Set wa = ThisWorkbook.Sheets("Test")
lRow = ws.Range("A" & Rows.Count).End(xlUp).Offset(3).Row
I2 = 11
Const fRow As Long = 2
Application.ScreenUpdating = False
For I = 2 To lRow 'sheets all have headers that are 2 rows
If Not (Application.WorksheetFunction.CountIf(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & I)) > 1 And _
Application.WorksheetFunction.CountIfs(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & I), ws.Range("AY" & fRow, "AY" & lRow), "Selected") = 1 _
And ws.Range("AY" & I) <> "Selected") Then
' If (uR Is Nothing) Then
' Set uR = Range(I & ":" & I)
' Else
' Set uR = Union(uR, Range(I & ":" & I))
' End If
I2 = I2 + 1
wa.Cells(I2, "A") = ws.Cells(I, "A")
wa.Cells(I2, "B") = ws.Cells(I, "B")
wa.Cells(I2, "C") = ws.Cells(I, "N")
wa.Cells(I2, "D") = ws.Cells(I, "X")
wa.Cells(I2, "E") = ws.Cells(I, "Y")
wa.Cells(I2, "G") = ws.Cells(I, "AY")
wa.Cells(I2, "H") = ws.Cells(I, "C")
wa.Cells(I2, "I") = ws.Cells(I, "D")
wa.Cells(I2, "J") = ws.Cells(I, "E")
wa.Cells(I2, "K") = ws.Cells(I, "F")
wa.Cells(I2, "R") = ws.Cells(I, "BI")
wa.Cells(I2, "S") = ws.Cells(I, "AT")
wa.Cells(I2, "T") = ws.Cells(I, "AU")
wa.Cells(I2, "U") = ws.Cells(I, "AV")
wa.Cells(I2, "V") = ws.Cells(I, "AW")
End If
Next I
'uR.copy Destination:=ws.Range("A13")
wb.Save
wb.Close
Application.ScreenUpdating = True
End Sub
If this can further be improved speed wise please let me know.
Tags: excelexcel