Looping "For Each" problem

[Steve C]

I have a column in which there are number values for each of five cells
(i.e., A1:A5), followed by a sum of those cells under that. The sum cell is
actually a merged cell (A6 & A7) and is bolded, font size 12. This pattern
continues down the column (5 individual cells with more numbers, then a
merged total under them) for hundreds of rows. My goal with my code is to
use a For Each statement that says for each bolded cell with font size 12 in
this selection, copy it, then switch to another workbook and paste a link to
that total. Then switch back, find the next bolded cell with font size 12,
and continue with each of the bolded cells until done.

My problem is that the For Each keeps going after the last bolded cell is
found; it isn't stopping at the last one, but rather restarts again with
first bolded cell. Here's my code; any help is appreciated!

Sub CopyAndPasteBoldedCells ( )
Dim BoldCell As Range

' Code here to select entire range in column

For Each BoldCell In Selection
With Application.FindFormat.Font
.FontStyle = "Bold"
.Size = 12
End With
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False, SearchFormat:=True).Activate

ActiveCell.Copy

' Code to activate other workbook and paste link, then return to this workbook

Next

 

[JMB]

that is because

For Each BoldCell In Selection

loops through each cell in the range (bold and those that are not so bold).
So if there are, for example, 5000 total cells in your range, the code
iterates 5000 times (and the find method is executed 5000 times), but there
are not 5000 cells w/totals in your range that you want to copy - so it
starts over at the top of the list.

Try:
For Each BoldCell In Selection.Cells
With BoldCell
If .Font.Bold And .Font.Size = 12 Then
.Copy
' Code to activate other workbook and paste link, then return to this
workbook
End If
End With
Next

 

[GS]

Hi Steve,
If I understand you correctly, the pattern you describe is consistant down
the sheet. This indicates that every 7 rows there's a new set of values.
Since rows 6+7 are merged, then every seventh row is empty. All you need to
do is loop through the blocks of 7 rows until you get to the last row with a
total. Here's some code you can start with:

Sub Macro1()

Dim lLastRow As Long, lRow As Long
Dim rngSource As Range, rngTarget As Range
Dim wkbSource As Workbook, wkbTarget As Workbook
Dim sAddress As Variant

'Get the first cell in the "Pattern"
'Pattern is: cells 1 to 5 have numeric values;
'Cells 6+7 are merged and contain total of (cells 1 to 5) contents.
sAddress = InputBox("Enter the range to start at.")
Set wkbSource = ActiveWorkbook
With wkbSource
'The last total is where we want to stop the loop
lLastRow = .ActiveSheet.Cells(Rows.Count,
Range(sAddress).Column).End(xlUp).Row
Range(sAddress).Select

Do
Selection.Offset(1).End(xlDown).Select

'Put a link to this cell in wkbTarget.Sheets(?)
'This kust puts the link in the adjacent cell to the right (for
testing only)
'Replace the following line with code to reference your other workbook.
Selection.Offset(, 1).Formula = "=" & Selection.Address

Loop Until Selection.Row = lLastRow
End With
End Sub

It's not necessary to actually select the other wkb or anything, which keeps
the wkbSource sheet the active sheet. Just set a qualified reference to it
like..

Set wkbTarget = Workbooks(?)
Set rngTarget = wkbTarget.Range(?)

What you didn't provide here is where to start on the target sheet, and what
to increment by. Did you want to put each total on a new row? ..need more
info!

hth
Garry

 

[GS]

This is the previous code revised to select nothing:

Sub Macro1()

Dim lLastRow As Long, lRow As Long
Dim rngSource As Range, rngTarget As Range
Dim wkbSource As Workbook, wkbTarget As Workbook
Dim sAddress As Variant

'Get the first cell in the "Pattern"
'Pattern is: cells 1 to 5 have numeric values;
'Cells 6+7 are merged and contain total of (cells 1 to 5) contents.
sAddress = InputBox("Enter the range to start at.")
Set wkbSource = ActiveWorkbook
Set rngSource = Range(sAddress)

'The last total is where we want to stop the loop
lLastRow = wkbSource.ActiveSheet.Cells(Rows.Count,
Range(sAddress).Column).End(xlUp).Row
Do
Set rngSource = rngSource.Offset(1).End(xlDown)
'Put a link to this cell in wkbTarget
rngSource.Offset(, 1).Formula = "=" & rngSource.Address
Loop Until rngSource.Row = lLastRow
End Sub

Regards,
Garry

 

[Steve C]

Thank you both for the help. It is much appreciated!