Copy entire row from "Sheet1" to "Sheet2" which is common between two columns

[fahadalambd]

Hi everyone,

Hope you are doing well. I need your help -

I need a VBA script that will copy the entire row from "Sheet1" to "Sheet2" which is common between "ColumnA" and "ColumnB"

In the attached pic, I mark in "Yellow" marks that needs to be copy from "Sheet1" to "Sheet2".

NB. My actual data sheet has almost 30000 rows. So I need a VBA script which will solve this problem.

Thank you so much.

 

[kevin9999]

A couple of tweaks/additions to your previous post could give you what you want?

Option Explicit
Sub fahadalambd_2()
    Application.ScreenUpdating = 0
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Set Ws1 = Worksheets("Sheet1")
    Set Ws2 = Worksheets("Sheet2")
    
    Dim LRow As Long
    LRow = Ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    With Ws1.Range("D2").Resize(LRow - 1)
        .Value = Evaluate("row(" & .Address & ")")
    End With
    
    Dim Rng As Range
    Set Rng = Ws1.Cells(1).CurrentRegion
    Rng.Sort Key1:=Ws1.Cells(1, 1), Order1:=1, Key2:=Ws1.Cells(1, 2), Order1:=1, Header:=1
    Set Rng = Rng.Resize(Rng.Rows.Count + 1, 2)
    
    Dim ArrIn, ArrOut, i As Long
    ArrIn = Rng
    ReDim ArrOut(1 To UBound(ArrIn, 1) - 1, 1 To 1)
    
    For i = 2 To UBound(ArrIn, 1) - 1
        If (ArrIn(i, 1) = ArrIn(i - 1, 1) Or ArrIn(i, 1) = ArrIn(i + 1, 1)) And _
        (ArrIn(i, 2) = ArrIn(i - 1, 2) Or ArrIn(i, 2) = ArrIn(i + 1, 2)) Then
        ArrOut(i, 1) = 1
        End If
    Next i
    Ws1.Range("E1").Resize(UBound(ArrOut, 1)).Value = ArrOut
    
    Set Rng = Rng.Resize(Rng.Rows.Count - 1, 5)
    Rng.Sort Key1:=Ws1.Cells(1, 5), Order1:=1, Header:=1
    i = WorksheetFunction.Sum(Ws1.Range("E:E"))
    Set Rng = Rng.Resize(i + 1, 3)
    
    With Rng
        .Copy Ws2.Cells(1)
    End With
    
    Set Rng = Ws1.Cells(1).CurrentRegion
    Rng.Sort Key1:=Ws1.Cells(1, 4), Order1:=1, Header:=1
    
    Ws1.Range("D:E").ClearContents
    Application.ScreenUpdating = 1
End Sub

 

[fahadalambd]

A couple of tweaks/additions to your previous post could give you what you want?

Option Explicit
Sub fahadalambd_2()
    Application.ScreenUpdating = 0
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Set Ws1 = Worksheets("Sheet1")
    Set Ws2 = Worksheets("Sheet2")
   
    Dim LRow As Long
    LRow = Ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    With Ws1.Range("D2").Resize(LRow - 1)
        .Value = Evaluate("row(" & .Address & ")")
    End With
   
    Dim Rng As Range
    Set Rng = Ws1.Cells(1).CurrentRegion
    Rng.Sort Key1:=Ws1.Cells(1, 1), Order1:=1, Key2:=Ws1.Cells(1, 2), Order1:=1, Header:=1
    Set Rng = Rng.Resize(Rng.Rows.Count + 1, 2)
   
    Dim ArrIn, ArrOut, i As Long
    ArrIn = Rng
    ReDim ArrOut(1 To UBound(ArrIn, 1) - 1, 1 To 1)
   
    For i = 2 To UBound(ArrIn, 1) - 1
        If (ArrIn(i, 1) = ArrIn(i - 1, 1) Or ArrIn(i, 1) = ArrIn(i + 1, 1)) And _
        (ArrIn(i, 2) = ArrIn(i - 1, 2) Or ArrIn(i, 2) = ArrIn(i + 1, 2)) Then
        ArrOut(i, 1) = 1
        End If
    Next i
    Ws1.Range("E1").Resize(UBound(ArrOut, 1)).Value = ArrOut
   
    Set Rng = Rng.Resize(Rng.Rows.Count - 1, 5)
    Rng.Sort Key1:=Ws1.Cells(1, 5), Order1:=1, Header:=1
    i = WorksheetFunction.Sum(Ws1.Range("E:E"))
    Set Rng = Rng.Resize(i + 1, 3)
   
    With Rng
        .Copy Ws2.Cells(1)
    End With
   
    Set Rng = Ws1.Cells(1).CurrentRegion
    Rng.Sort Key1:=Ws1.Cells(1, 4), Order1:=1, Header:=1
   
    Ws1.Range("D:E").ClearContents
    Application.ScreenUpdating = 1
End Sub

Thank you so much mate. I must have to say you are very genius and intelligent. Thanks again for your enormous help. This script is working perfectly.

 

[kevin9999]

you are very genius and intelligent

You clearly don't know me too well

Happy to help & thank you for the feedback