if a row has unhighlighted data after the 2nd highlighted cell then copy the data from 2nd highlighted cell till last data and paste to sheet2

go to each row of table1,table2,table3,table4
if a row has unhighlighted data after the 2nd highlighted cell then copy the data from 2nd highlighted cell till last data and paste to sheet2
and if not then simply copy that row and paste that data to sheet2
I want to do this by vba
see the result in sheet2
Kindly see the sample file
Sample123--2-.xlsm
Avinash SinghAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Please give this a try...
In the attached, click the button on Sheet1 to run the code to produce the desired output on Sheet2.

Sub CopyDataAfterSecondHighlightedCell()
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, slc As Long

Dim lr As Long, lc As Long, i As Long, j As Long, jj As Long, k As Long, c As Long, cnt As Long
Dim Rng As Range
Application.ScreenUpdating = False

Set sws = Sheets("Sheet1")
Set dws = Sheets("Sheet2")

slr = sws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
slc = sws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
dws.Cells.Clear
sws.Range("A1", sws.Cells(slr, slc)).Copy dws.Range("A1")

lr = dws.Cells(Rows.Count, 1).End(xlUp).Row
For Each Rng In dws.Range("A1:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
    For i = Rng.Cells(2).Row To Rng.Cells(Rng.Cells.Count).Row
        lc = dws.Cells(i, Columns.Count).End(xlToLeft).Column
        For j = 2 To lc
            If dws.Cells(i, j).Interior.ColorIndex <> xlNone Then
                For jj = j + 1 To lc
                    If dws.Cells(i, jj).Interior.ColorIndex = xlNone Then
                        cnt = cnt + 1
                        j = jj
                        Exit For
                    End If
                Next jj
                If cnt = 2 Then
                    For k = jj - 1 To 2 Step -1
                        If dws.Cells(i, k).Interior.ColorIndex = xlNone Then
                            c = k
                            Exit For
                        End If
                    Next k
                    Exit For
                End If
            End If
        Next j
        
        If cnt = 2 Then
            dws.Range(dws.Cells(i, 2), dws.Cells(i, c)).Delete shift:=xlToLeft
        End If
        cnt = 0
        c = 0
    Next i
Next Rng
dws.Activate
Application.ScreenUpdating = True
End Sub

Open in new window

Sample123--2.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Avinash SinghAuthor Commented:
Thnx again Neeraj sir
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Avinash! :)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.