PDA

View Full Version : [SOLVED] Copy/Paste Based on Multiple Row Criteria



BenChod
05-30-2017, 06:10 AM
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
05-30-2017, 10:45 AM
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
05-30-2017, 02:14 PM
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
05-30-2017, 02:16 PM
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
05-30-2017, 02:24 PM
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
05-30-2017, 02:53 PM
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
05-30-2017, 03:42 PM
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
05-30-2017, 04:11 PM
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
05-30-2017, 04:11 PM
Thank you so much for helping out. You are the man. It worked perfectly.

BenChod
05-30-2017, 04:14 PM
Sorry, one more thing, if you don't mind. Can you please explain what the code is doing.

mdmackillop
05-31-2017, 12:51 AM
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