Replace specific number in search criteria with integer and copy that many places

[Mattrick2oo3]

Posted a thread the other day that got no traction but managed to get something working. The Code below looks for "4 Places", activates that cell, offsets and copies and pastes selection.


Sub Places()

Application.ScreenUpdating = False

Dim ResultCell As Range
Dim UsedRng As Range, LastRow As Long
Set UsedRng = ActiveSheet.UsedRange

Do

Set ResultCell = Sheets("Form3").UsedRange.Find(What:="4 Places", LookIn:=xlFormulas, MatchCase:=False)
LastRow = UsedRng(UsedRng.Cells.Count).Row

If Not ResultCell Is Nothing Then
ResultCell.Activate
ActiveCell.Offset(0, -3).Select
Selection.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(4, 0)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 3).Activate
ActiveCell.Offset(0, -6).Select
Selection.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(4, 0)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 6).Activate
ActiveCell.EntireRow.Delete

Else

Exit Do

End If



Loop Until ActiveCell.Row = LastRow + 1

End Sub

Would like to be able to replace the "4" with an integer and have the selected range for paste use that many spaces. Any help would be greatly appreciated.

Thanks,

-Matt

 

[dizmal]

Hi Matt, you can set a variable and use that instead of the number. Assuming I'm understanding your question correctly, the code below uses an input box to let you select the number of rows you want to copy, and then uses that value on your select rows.

Sub Places()

Application.ScreenUpdating = False

Dim ResultCell As Range
Dim UsedRng As Range, LastRow As Long
Set UsedRng = ActiveSheet.UsedRange

Do

Set ResultCell = Sheets("Form3").UsedRange.Find(What:="4 Places", LookIn:=xlFormulas, MatchCase:=False)
LastRow = UsedRng(UsedRng.Cells.Count).Row

'Ask for number of rows to copy
intCopyRows = InputBox("Enter number of rows to copy")


If Not ResultCell Is Nothing Then
ResultCell.Activate
ActiveCell.Offset(0, -3).Select
Selection.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(intCopyRows, 0)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 3).Activate
ActiveCell.Offset(0, -6).Select
Selection.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(intCopyRows, 0)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 6).Activate
ActiveCell.EntireRow.Delete

Else

Exit Do

End If



Loop Until ActiveCell.Row = LastRow + 1

End Sub

 

[Mattrick2oo3]

Dizmal,

Thanks for your reply but I need something a little different. The intent is for the user not to be prompted with anything and do it automatically.

See below:

Sub Places()

Application.ScreenUpdating = False

Dim ResultCell As Range
Dim UsedRng As Range, LastRow As Long
Set UsedRng = ActiveSheet.UsedRange

Do

Set ResultCell = Sheets("Form3").UsedRange.Find(What:="4 Places", LookIn:=xlFormulas, MatchCase:=False)
LastRow = UsedRng(UsedRng.Cells.Count).Row

If Not ResultCell Is Nothing Then
ResultCell.Activate
ActiveCell.Offset(0, -3).Select
Selection.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(4, 0)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 3).Activate
ActiveCell.Offset(0, -6).Select
Selection.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(4, 0)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 6).Activate
ActiveCell.EntireRow.Delete

Else

Exit Do

End If



Loop Until ActiveCell.Row = LastRow + 1

End Sub

There are multiple "places" (ie 2 Places, 3 Places, 4 Places, etc.). I need it to search for a cell that contains an integer and the string "places", and offset the range to that number. The aboce is only for 4 places and has the range offset set to 4 as highlighted. Need both numbers replaced by whatever integer it finds.

Thanks,

-Matt

 

[dizmal]

Ahh, I interpreted your question differently. Can there be more than one instance of "# places"? If there's only one, you can substitute "4 places" with "* places" and then use a Left string to save the number to a variable, which can then be used in your Select statement. Examples of the lines in question:

The following lines will find the cell no matter what the number in front of "Places" is. It will then take the number at the beginning and assign it to the "intRowCopy" variable. You can of course name the variable whatever you want.

Set ResultCell = Sheets("Form3").UsedRange.Find(What:="*Places", LookIn:=xlFormulas, MatchCase:=False)
intRowCopy = Left(ResultCell.Value, 1)

Then you can substitute the 4 in your two select statements with the variable you just defined.

Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(intRowCopy, 0)).Select

It gets more complicated if you can have multiple instances of "* places" on each sheet, because you have to loop through each instance and either change each instance of "* places" so it doesn't doing it again, or use the offset data to see if you've already done the copy. It's difficult to determine the best solution without seeing the spreadsheet itself.

I hope this gets you what you're looking for!

 

[dizmal]

Actually, slight change to make it more error proof. The code I gave above will only work if the # in "# Places" is a single digit. If you think it can be multiple digits, use this instead:

Set ResultCell = Sheets("Form3").UsedRange.Find(What:="*Places", LookIn:=xlFormulas, MatchCase:=False)
intRowCopy = Trim$(Left$(ResultCell.Value, InStr(ResultCell.Value, " ") - 1))

 

[Mattrick2oo3]

Dizmal,

This works perfectly except I get Run-Time Error 91 on the line

intRowCopy = Trim$(Left$(ResultCell.Value, InStr(ResultCell.Value, " ") - 1))

It does exactly what I want it to until there are no longer and cells that contain "*Places" then gets to this line and errors.

Thanks,

-Matt

 

[dizmal]

Hi Matt, right after the line where you search for "*Places", you can add the following line which will exit the do loop if there are no more instances of "*Places".

Set ResultCell = Sheets("Form3").UsedRange.Find(What:="*Places", LookIn:=xlFormulas, MatchCase:=False)
If ResultCell Is Nothing Then Exit Do

Let me know if that doesn't get you squared away!