Paste cells before or after certain rows

T

topi1

Active Member
Joined
Aug 6, 2014
Messages
252
Office Version
  1. 2010
I was hoping to get a macro for the following two-part function. Thank you.
Trying to copy and paste Based on first occurrence in the cells.
The data is in sheet2.
Hoping for case-insensitive match.

Part I
When the cells below TITLE2 start with "After" or "Below", want the rows to be copied and pasted above TITLE2 row, below the row where column O cell is identical.

Part II
When the cells below TITLE2 start with "Before" or "Above", want the rows to be copied and pasted above TITLE2 row, above the row where column O cell is identical.

I can use formulas, but I would like to use VBA if possible.

Here is the example

Before:

Book3
OPQR
1Theater:
2Movie:
3
4
5TITLE1
6
7ErosEros:4Eros: Dunn
8RegalRegal:4Regal: Superman
9MetroMetro:4Metro: Batman
10MinervaMinerva:4Minerva: Starwars
11
12
13TITLE2
14Eros shows Superman nextweek. Delim4.
15Metro shows Dunn next month. Delim3. Closed today.
16Delim2. Minerva is showing Abba.
17MetroPlace4Before Metro Roxi shows Cars.
18ErosPlace4After Eros Strand shows Abba.
19ErosPlace4After Eros Mandir shows Sholay
20MetroPlace4Before Metro Opera House shows Shor
Sheet2


After:

Book3
OPQR
1Theater:
2Movie:
3
4
5TITLE1
6
7ErosEros:4Eros: Dunn
8ErosPlace4After Eros Strand shows Abba.
9ErosPlace4After Eros Mandir shows Sholay
10RegalRegal:4Regal: Superman
11MetroPlace4Before Metro Roxi shows Cars.
12MetroPlace4Before Metro Opera House shows Shor
13MetroMetro:4Metro: Batman
14MinervaMinerva:4Minerva: Starwars
15
16
17TITLE2
18Eros shows Superman nextweek. Delim4.
19Metro shows Dunn next month. Delim3. Closed today.
20Delim2. Minerva is showing Abba.
21MetroPlace4Before Metro Roxi shows Cars.
22ErosPlace4After Eros Strand shows Abba.
23ErosPlace4After Eros Mandir shows Sholay
24MetroPlace4Before Metro Opera House shows Shor
Sheet2
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
Try:
VBA Code: 
Sub FindCopySort()
    Dim ws As Worksheet
    Dim startCellR As Range
    Dim lastRow As Long
    Dim firstNonBlankO As Long
    Dim title2Range As Variant
    Dim result() As Variant
    Dim i As Long, j As Long, k As Long

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sheet2")
    On Error GoTo 0
    

    Dim startCellRTitle1 As Range
    Set startCellRTitle1 = ws.Columns("R").Find(What:="TITLE1", LookIn:=xlValues, LookAt:=xlWhole)
    If startCellRTitle1 Is Nothing Then Exit Sub

    Set startCellR = ws.Columns("R").Find(What:="TITLE2", LookIn:=xlValues, LookAt:=xlWhole)
    If startCellR Is Nothing Then Exit Sub

    lastRow = ws.Cells(ws.Rows.Count, "R").End(xlUp).Row
    If lastRow < startCellR.Row Then Exit Sub
    
    title2Range = ws.Range(startCellR.Offset(0, -3), ws.Cells(lastRow, "R")).Value
    firstNonBlankO = ws.Columns("O").SpecialCells(xlCellTypeConstants).Cells(1, 1).Row
    If firstNonBlankO = 0 Then Exit Sub
    
    ReDim result(1 To UBound(title2Range, 1), 1 To 4)
    j = 1
    For i = 2 To UBound(title2Range, 1)
        If InStr(1, title2Range(i, 4), "After", vbTextCompare) > 0 Or _
           InStr(1, title2Range(i, 4), "Before", vbTextCompare) > 0 Then
            For k = 1 To 4
                result(j, k) = title2Range(i, k)
            Next k
            j = j + 1
        End If
    Next i
    
    If j > 1 Then
        ws.Rows(firstNonBlankO + 1 & ":" & firstNonBlankO + UBound(result, 1)).Insert Shift:=xlDown
        ws.Range("O" & firstNonBlankO + 1).Resize(UBound(result, 1), 4).Value = result

        Dim sortRng As Range
        Set sortRng = ws.Range(ws.Cells(startCellRTitle1.Row + 1, "O"), ws.Cells(startCellR.Row - 1, "R"))
        sortRng.Sort Key1:=ws.Range("O" & startCellRTitle1.Row + 1), Order1:=xlAscending, Header:=xlNo
        
        Dim delRange As Range
        For Each cell In ws.Range(ws.Cells(startCellRTitle1.Row + 1, "R"), ws.Cells(startCellR.Row - 1, "R"))
            If IsEmpty(cell) Then
                If delRange Is Nothing Then
                    Set delRange = cell
                Else
                    Set delRange = Union(delRange, cell)
                End If
            End If
        Next cell
        If Not delRange Is Nothing Then delRange.EntireRow.Delete
    End If
End Sub
 
Upvote 0
@Cubist. Thank you. It worked like a charm. Had been struggling with it. Mine was only doing one instance of "After". This one is perfect.
 
Upvote 0
Cubist said:
Try:
VBA Code: 
Sub FindCopySort()
    Dim ws As Worksheet
    Dim startCellR As Range
    Dim lastRow As Long
    Dim firstNonBlankO As Long
    Dim title2Range As Variant
    Dim result() As Variant
    Dim i As Long, j As Long, k As Long

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sheet2")
    On Error GoTo 0
   

    Dim startCellRTitle1 As Range
    Set startCellRTitle1 = ws.Columns("R").Find(What:="TITLE1", LookIn:=xlValues, LookAt:=xlWhole)
    If startCellRTitle1 Is Nothing Then Exit Sub

    Set startCellR = ws.Columns("R").Find(What:="TITLE2", LookIn:=xlValues, LookAt:=xlWhole)
    If startCellR Is Nothing Then Exit Sub

    lastRow = ws.Cells(ws.Rows.Count, "R").End(xlUp).Row
    If lastRow < startCellR.Row Then Exit Sub
   
    title2Range = ws.Range(startCellR.Offset(0, -3), ws.Cells(lastRow, "R")).Value
    firstNonBlankO = ws.Columns("O").SpecialCells(xlCellTypeConstants).Cells(1, 1).Row
    If firstNonBlankO = 0 Then Exit Sub
   
    ReDim result(1 To UBound(title2Range, 1), 1 To 4)
    j = 1
    For i = 2 To UBound(title2Range, 1)
        If InStr(1, title2Range(i, 4), "After", vbTextCompare) > 0 Or _
           InStr(1, title2Range(i, 4), "Before", vbTextCompare) > 0 Then
            For k = 1 To 4
                result(j, k) = title2Range(i, k)
            Next k
            j = j + 1
        End If
    Next i
   
    If j > 1 Then
        ws.Rows(firstNonBlankO + 1 & ":" & firstNonBlankO + UBound(result, 1)).Insert Shift:=xlDown
        ws.Range("O" & firstNonBlankO + 1).Resize(UBound(result, 1), 4).Value = result

        Dim sortRng As Range
        Set sortRng = ws.Range(ws.Cells(startCellRTitle1.Row + 1, "O"), ws.Cells(startCellR.Row - 1, "R"))
        sortRng.Sort Key1:=ws.Range("O" & startCellRTitle1.Row + 1), Order1:=xlAscending, Header:=xlNo
       
        Dim delRange As Range
        For Each cell In ws.Range(ws.Cells(startCellRTitle1.Row + 1, "R"), ws.Cells(startCellR.Row - 1, "R"))
            If IsEmpty(cell) Then
                If delRange Is Nothing Then
                    Set delRange = cell
                Else
                    Set delRange = Union(delRange, cell)
                End If
            End If
        Next cell
        If Not delRange Is Nothing Then delRange.EntireRow.Delete
    End If
End Sub
Click to expand...
@Cubist follow up. The code often gives two unintended results. 1) It puts the "After" item before instead of after or below the specific row. 2) It rearranges other rows. TY. Any solution? TY.
 
Upvote 0
Can you provide the sample data when these issues occur?
 
Upvote 0
@Cubist Here are the before and after examples.
AS you can see, After EROS was pasted above and not below the original row.
Also, the row order seems to have changed alphabetically instead of keeping original position.
(Sorry about the columns Z etc. I just moved it to demonstrate. Before also was in O to R)
Thank you so much for looking into it.

BEFORE:
project_try7 A.xlsm
ZAAABAC
66Theater:
67Movie:
68findings:
69RegalRegal:4Regal: Dunn
70ErosEros:4Eros: Superman
71MetroMetro:4Metro: Batman
72MinervaMinerva:4Minerva: Starwars
73IMPRESSION:
74Eros shows Superman nextweek. Delim4.
75Metro shows Dunn next month. Delim3. Closed today.
76Delim2. Minerva is showing Abba.
77MetroPlaceBefore Metro Roxi shows Cars.
78ErosPlaceAfter Eros Strand shows Abba.
Sheet2


AFTER:
project_try7 A.xlsm
OPQR
1Theater:
2Movie:
3findings:
4ErosPlaceAfter Eros Strand shows Abba.
5ErosEros:4Eros: Superman
6MetroPlaceBefore Metro Roxi shows Cars.
7MetroMetro:4Metro: Batman
8MinervaMinerva:4Minerva: Starwars
9RegalRegal:4Regal: Dunn
10IMPRESSION:
11Eros shows Superman nextweek. Delim4.
12Metro shows Dunn next month. Delim3. Closed today.
13Delim2. Minerva is showing Abba.
14MetroPlaceBefore Metro Roxi shows Cars.
15ErosPlaceAfter Eros Strand shows Abba.
Sheet2
 
Upvote 0
It's because there's no literal string "TITLE2". In column AC, how can you tell "IMPRESSION:" is the title?
 
Upvote 0
Sorry. Reran. Same issues.

BEFORE

Only necessary VBA.xlsm
OPQR
1Theater:
2Movie:
3TITLE1
4RegalRegal:4Regal: Dunn
5ErosEros:4Eros: Superman
6MetroMetro:4Metro: Batman
7MinervaMinerva:4Minerva: Starwars
8TITLE2
9Eros shows Superman nextweek. Delim4.
10Metro shows Dunn next month. Delim3. Closed today.
11Delim2. Minerva is showing Abba.
12MetroPlaceBefore Metro Roxi shows Cars.
13ErosPlaceAfter Eros Strand shows Abba.
Sheet3


AFTER

Only necessary VBA.xlsm
OPQR
1Theater:
2Movie:
3TITLE1
4ErosPlaceAfter Eros Strand shows Abba.
5ErosEros:4Eros: Superman
6MetroPlaceBefore Metro Roxi shows Cars.
7MetroMetro:4Metro: Batman
8MinervaMinerva:4Minerva: Starwars
9RegalRegal:4Regal: Dunn
10TITLE2
11Eros shows Superman nextweek. Delim4.
12Metro shows Dunn next month. Delim3. Closed today.
13Delim2. Minerva is showing Abba.
14MetroPlaceBefore Metro Roxi shows Cars.
15ErosPlaceAfter Eros Strand shows Abba.
Sheet2
 
Upvote 0
@Cubist I reran the code in Office 365. It still rearranged the entire rows between TITLE1 and TITLE2 alphabetically per column O.

Regal
Eros
Minerva
Metro

became

Eros
Metro
Minerva
Regal

I was hoping to keep rest of the rows untouched and in the same sort.

If you have time and able to help, greatly appreciate it.


BEFORE:
Before.xlsx
OPQR
1Theater:
2Movie:
3TITLE1
4RegalRegal:4Regal: Superman
5ErosEros:4Eros: Dunn
6MinervaMinerva:4Minerva: Starwars
7MetroMetro:4Metro: Batman
8TITLE2
9Eros shows Superman nextweek. Delim4.
10Metro shows Dunn next month. Delim3. Closed today.
11Delim2. Minerva is showing Abba.
12MetroPlace4Before Metro Roxi shows Cars.
13ErosPlace4After Eros Strand shows Abba.
14ErosPlace4After Eros Mandir shows Sholay
15MetroPlace4Before Metro Opera House shows Shor
Sheet1 (2)


AFTER:
Before.xlsx
OPQR
1Theater:
2Movie:
3TITLE1
4ErosPlace4After Eros Strand shows Abba.
5ErosPlace4After Eros Mandir shows Sholay
6ErosEros:4Eros: Dunn
7MetroPlace4Before Metro Roxi shows Cars.
8MetroPlace4Before Metro Opera House shows Shor
9MetroMetro:4Metro: Batman
10MinervaMinerva:4Minerva: Starwars
11RegalRegal:4Regal: Superman
12TITLE2
13Eros shows Superman nextweek. Delim4.
14Metro shows Dunn next month. Delim3. Closed today.
15Delim2. Minerva is showing Abba.
16MetroPlace4Before Metro Roxi shows Cars.
17ErosPlace4After Eros Strand shows Abba.
18ErosPlace4After Eros Mandir shows Sholay
19MetroPlace4Before Metro Opera House shows Shor
Sheet3
 
Upvote 0
Give this a try.
VBA Code: 
Sub FindCopyInsert()
    Dim ws As Worksheet
    Dim title1Cell As Range
    Dim title2Cell As Range
    Dim titleRange As Range, titleRange2 As Range
    Dim cell As Range, foundCell As Range
    Dim firstWord As String
  
    Set ws = ThisWorkbook.Sheets("Sheet1") '<- Change sheet name to suit.
  
    Set title1Cell = ws.Columns("R").Find(What:="TITLE1", LookIn:=xlValues, LookAt:=xlWhole)
    Set title2Cell = ws.Columns("R").Find(What:="TITLE2", After:=title1Cell, LookIn:=xlValues, LookAt:=xlWhole)
  
    Set titleRange = ws.Range(ws.Cells(title1Cell.Row + 1, "O"), ws.Cells(title2Cell.Row - 1, "O"))
    Set titleRange2 = ws.Range(ws.Cells(title2Cell.Row + 1, "O"), ws.Cells(ws.Rows.Count, "O").End(xlUp))
  
    For Each cell In titleRange2
        Set foundCell = titleRange.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
      
        If Not foundCell Is Nothing Then
            firstWord = Split(ws.Cells(cell.Row, "R").Value)(0)
          
            If firstWord = "Before" Then
                foundCell.EntireRow.Insert Shift:=xlDown
                ws.Range(ws.Cells(cell.Row, "O"), ws.Cells(cell.Row, "R")).Copy Destination:=foundCell.Offset(-1, 0)
            ElseIf firstWord = "After" Then
                foundCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
                ws.Range(ws.Cells(cell.Row, "O"), ws.Cells(cell.Row, "R")).Copy Destination:=foundCell.Offset(1, 0)
            End If
        End If
    Next cell
End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

T
  • Solved
Match and delete
4 5 6
Replies
55
Views
1K
topi1
T
T
  • Solved
Substitution and removing of the string
2
Replies
11
Views
546
topi1
T
T
  • Question Question
VBA for complex match and mismatch
Replies
1
Views
230
Rhodie72
Rhodie72
WildBurrow
  • Question Question
Copy/Paste data to next empty row within a range - WITHOUT shifting subsequent rows up
Replies
0
Views
405
WildBurrow
WildBurrow
A
  • Solved
Inserting new rows based on cell value, and copying data to the new rows
Replies
5
Views
2K
Andrew87
A

Forum statistics

Threads
1,223,893
Messages
6,175,241
Members
452,622
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top