VBA Test for so Called Experts - Haven't found a winner yet

[weston.perkins]

I presently have a code to search for a counter in column B on my
selected page. The counter signals where to take the last row above
the counter and insert a new row with copied formats and formulas.
This works, however, several of the rows above that have formulas
that
dont populate correctly due to their links between the rows. What I
need is help with selecting a range of rows (12 to be exact) above my
counter at the end of my list, and then copy those 12 rows exactly
and
insert them between the the counter and the 12 rows copied.
Currently
the code I have only takes a single row 12 rows above the counter and
inserts a copy of that row above the counter. I tried using a macro
to use this application 12 times in a row to simulate what I need
done
in one step, but this caused the formula errors that did not populate
correctly. If anyone could give me some insight to altering the
code
to select a range of 12 rows then insert those above the counter, it
would be greatly appreciated.

Below is the code:


Sub InsertNewProductListInfo()
Dim objCurrentSheet
Dim rngCopiedCells
Dim rngInsertedCells
Dim rngLastRow
Dim intRowIndex
Dim strFromRange
Dim strToRange
Dim strLastRowRange
Dim dtLastDayOfMonth
Dim index


Set objCurrentSheet = Sheets(ActiveSheet.Name)


For counter = 1 To objCurrentSheet.Rows.Count 'Start of first
Loop
Set curCell = objCurrentSheet.Rows(counter).Cells(2)
'MsgBox Worksheets("Invent -
Rev").Rows(counter).Cells(2).Text
If Trim(LCase((curCell.Text))) = "product list info" Then
'12 Rows above Product List Info row
intRowIndex = counter - 12
'Gets cells that will make up each of the ranges
strFromRange = "A" & intRowIndex & ":FO" & intRowIndex
strToRange = "A" & counter & ":FO" & counter
strLastRowRange = "A" & (counter) & ":FO" & (counter)


'Set the range of cells used to copy into the new row
Set rngCopiedCells = objCurrentSheet.Range(strFromRange)
'Insert a row above the Product List Info line
objCurrentSheet.Rows(counter).Insert (xlDown)
'Range copied to
Set rngInsertedCells = objCurrentSheet.Range(strToRange)
'Range for last row
Set rngLastRowRange =
objCurrentSheet.Range(strLastRowRange)
'Copy the source range with the second range as the
destination
rngCopiedCells.Copy (rngInsertedCells)
rngCopiedCells.Copy (rngLastRowRange)


Exit Sub


End If
Next counter 'End of first loop


End Sub

 

[Roger Whitehead]

Hi Weston,

There may be reasons why you set the ActiveSheet as an object - apologies
that I've partly trashed that below. I hope I've undertsood you correctly.
Your Range appears to be in columns A:FO, which may in itself present
problems if there is data beyond column FO. Might be best to work with rows
in their entirety. Anyway - see how this goes.

--
HTH
Roger
Shaftesbury (UK)



Dim LastRow as long, LastCol as Long
'Useful -
Sub getLast()
lastRow =
ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
lastCol =
ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
End Sub

Sub InsertNewProductListInfo()
Dim rngSelectRange as range
Dim objCurrentSheet
Dim rngCopiedCells
Dim rngInsertedCells
Dim rngLastRow
Dim intRowIndex
Dim dtLastDayOfMonth
Dim index

GetLast 'Call the above routine

Set objCurrentSheet = activesheet

For counter = 1 To lastrow step 1 'Start of first Loop
Set curCell = Cells(counter,2)
'MsgBox Worksheets("Invent -> Rev").Cells(counter,2).Text
If Trim(LCase((curCell.Text))) = "product list info" Then
'12 Rows above Product List Info row
intRowIndex = counter - 12
'Assign the range to be copied -
Set rngSelectRange = range("A" & intRowIndex & ":FO" &
counter-1)

rngSelectRange.Copy
rngSelectRange.Insert Shift:=xlDown

Exit Sub

End If
Next counter 'End of first loop

End Sub