Copy/Paste Based on Multiple Row Criteria

[BenChod]

Hi -

I am trying to figure out a way to use VBA code to copy the contents of a row based on a criteria down multiple cells until the next row that has a different value. Then I want the new value to be copied and pasted down until the next row has a different value, etc. Attached is the sample worksheet. In the worksheet, you will see the various regions. I want the region to be copied to column A until the next region and then copy that region down, and etc.


Here is the code I came up with but it doesn't work

With Sheets("Summary")
lastcolumn1 = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
End With
lastrow3 = Sheets("Summary").Range("B" & Rows.Count).End(xlUp).Row


For i = 2 To lastrow3


If Cells(i, 2).Value = "East Region " Then
Range("A5" & lastrow3").Value = "East Region "
ElseIf Cells(i, 2).Value = "Midwest Region" Then
Range("A5" & lastrow 3).Value = "Midwest Region"
ElseIf Cells(i, 2).Value = "West Region" Then
Range("A5" & lastrow3).Value = "West Region"


End If
Next


Application.ScreenUpdating = True


End Sub

[mdmackillop]

With Sheets("Summary")
lastrow3 = .Range("C" & Rows.Count).End(xlUp).Row
Set Rng = Range(.Cells(4, 3), .Cells(lastrow3, 3))
For Each cel In Rng.SpecialCells(xlCellTypeBlanks)
    If cel = "" Then
        Set tgt = Range(cel(2), cel(2).End(xlDown))
        tgt.Offset(, -2) = cel.Offset(, -1)
    End If
Next cel
End With

[BenChod]

With Sheets("Summary")
lastrow3 = .Range("C" & Rows.Count).End(xlUp).Row
Set Rng = Range(.Cells(4, 3), .Cells(lastrow3, 3))
For Each cel In Rng.SpecialCells(xlCellTypeBlanks)
    If cel = "" Then
        Set tgt = Range(cel(2), cel(2).End(xlDown))
        tgt.Offset(, -2) = cel.Offset(, -1)
    End If
Next cel
End With

[BenChod]

Thank you so much, it worked like a charm.

I do have a question. The row header (regions), that is a merged cell. When I run your code, the region names are not populated down. I tried to change the code to select another blank cell and that didn't work. Is there a way to modify it? Thanks again for your help.

[mdmackillop]

I'm confused. You say it works but also that the region names are not populated down.
The only merged cell in the posted example is "Summary", otherwise my solution would not work.
I don't see the need for merged cells here. Even Summary could be "Centre Across Selection"

[BenChod]

I unmerged the cells (region headers) when I posted the worksheet. I received the worksheet with the region headers as merged. When I apply your code, it's not populating the cells with the correct region based on the region header. This is when I tried to move the cell reference to another empty cell and that didn't work either. When I a run another code to unmerge the cells, all the area where the merge was populates the cells with the merged cell value, which is what I want , but not for the headers.

I have attached the worksheet I receive without the cells being unmerged.

[mdmackillop]

With Sheets("Summary")
    lastrow3 = .Range("D" & Rows.Count).End(xlUp).Row
    Set Rng = Range(.Cells(2, 4), .Cells(lastrow3, 4))
    For Each cel In Rng.Columns(1).Cells
        If cel = "" Then
            Set tgt = Range(cel(2), cel(2).End(xlDown))
            tgt.Offset(, -2) = cel.Offset(, -1)
        End If
    Next cel
End With

[BenChod]

With Sheets("Summary")
    lastrow3 = .Range("D" & Rows.Count).End(xlUp).Row
    Set Rng = Range(.Cells(2, 4), .Cells(lastrow3, 4))
    For Each cel In Rng.Columns(1).Cells
        If cel = "" Then
            Set tgt = Range(cel(2), cel(2).End(xlDown))
            tgt.Offset(, -2) = cel.Offset(, -1)
        End If
    Next cel
End With

[BenChod]

Thank you so much for helping out. You are the man. It worked perfectly.

[BenChod]

Sorry, one more thing, if you don't mind. Can you please explain what the code is doing.

[mdmackillop]

With Sheets("Summary") 
    lastrow3 = .Range("D" & Rows.Count).End(xlUp).Row 
    
Set Rng = Range(.Cells(2, 4), .Cells(lastrow3, 4)) 'Set the column to process
    For Each cel In Rng.Columns(1).Cells 'Look at each cell
        If cel = "" Then 'If blank
            Set tgt = Range(cel(2), cel(2).End(xlDown)) 'set range from next cell to last filled cell
            tgt.Offset(, -2) = cel.Offset(, -1) 'find the data relative to the empty cell and copy to range relative to last range
        End If 
    Next cel 
End With