Hey there! I am looking for a way to automatically copy paste values from one sheet to another based on the contents of the column in the following way:

- If a cell in column M in Sheet 1 mentions "Phase 1", I want to copy the contents of Columns A, C and D of the same row and paste them to cells F4, G4, H4, I4 of Sheet 2. (F4 being Phase 1 and G4,H4,I4 being the column A,C and D entries respectively)

- I want this to be repeated until the last "Phase 1" value on column M is found and I want the data to be pasted in the next row each time (so if the first "Phase 1" row gets pasted to F4, G4, H4, I4, I want the second row to be pasted to F5, G5, H5, I5) in the same worksheet.)

- Then I want to do the same with "Phase 2" but starting 4 rows below where the "Phase 1" entries ended in Sheet 2.

I am new to VBA so let me know whether this is clear - happy to provide any extra information if otherwise.

message edited by Odysseus

How's this look? It copies all of Phase 1, then all of Phase 2, then goes back and finds the first occurrence of Phase 2 on Sheet2 and inserts 3 "Spacer Rows". The end result is that Phase 2 starts 4 rows below the end of Phase 1.

Option Explicit Sub CopyPhases() Dim m As Range Dim m1 As Range Dim m2 As Range Dim nxtRw As Long Dim firstAddress As String 'Copy Phase 1 Data With Sheets(1).Columns(13) Set m1 = .Find("Phase 1", LookIn:=xlValues) If Not m1 Is Nothing Then firstAddress = m1.Address Do nxtRw = Sheets(2).Cells(Rows.Count, "F").End(xlUp).Row + 1 Sheets(1).Cells(m1.Row, "M").Copy Sheets(2).Cells(nxtRw, "F") Sheets(1).Cells(m1.Row, "A").Copy Sheets(2).Cells(nxtRw, "G") Sheets(1).Cells(m1.Row, "C").Copy Sheets(2).Cells(nxtRw, "H") Sheets(1).Cells(m1.Row, "D").Copy Sheets(2).Cells(nxtRw, "I") Set m1 = .FindNext(m1) Loop While m1.Address <> firstAddress End If End With 'Copy Phase 2 Data With Sheets(1).Columns(13) Set m2 = .Find("Phase 2", LookIn:=xlValues) If Not m2 Is Nothing Then firstAddress = m2.Address Do nxtRw = Sheets(2).Cells(Rows.Count, "F").End(xlUp).Row + 1 Sheets(1).Cells(m2.Row, "M").Copy Sheets(2).Cells(nxtRw, "F") Sheets(1).Cells(m2.Row, "A").Copy Sheets(2).Cells(nxtRw, "G") Sheets(1).Cells(m2.Row, "C").Copy Sheets(2).Cells(nxtRw, "H") Sheets(1).Cells(m2.Row, "D").Copy Sheets(2).Cells(nxtRw, "I") Set m2 = .FindNext(m2) Loop While m2.Address <> firstAddress End If End With 'Insert Spacer Rows With Sheets(2).Columns(6) Set m = .Find("Phase 2", LookIn:=xlValues) If Not m Is Nothing Then .Rows(m.Row & ":" & m.Row + 2).EntireRow.Insert shift:=xlDown End If End With End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.

message edited by DerbyDad03

Works perfectly - exactly what I needed! Many thanks!

message edited by Odysseus

Ask Your Question

Weekly Poll