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?
 
Subodh Tiwari (Neeraj)Connect With a Mentor 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
 
Avinash SinghAuthor Commented:
Thnx again Neeraj sir
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Avinash! :)
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.