Check row Condition to copy and paste from 1 Workb

Question

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.

Answer 1

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 non-unique "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 non-unique 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 2

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.