Create/copy combo boxes in one range if condition is met in a different range

[LB]

Based on your excellent advice, I was able to use the code below to
create a macro to create/copy combo boxes in the range B22:B33.
However, I only need to have the combo box show up in column B if there
is data in the same row in column A. In other words, if column A same
row is blank, then I need the macro to stop.

1. What is the code to do this conditional execution?
2. I also want the background color of these combo boxes to be yellow.
What code do I need to insert into my existing code to do that?

Thanks in advance for your assistance.

Dim myOLEObj As OLEObject
Dim myRng As Range
Dim myCell As Range

With ActiveSheet
Set myRng = .Range("b22:b33")
For Each myCell In myRng.Cells

With myCell
Set myOLEObj = .Parent.OLEObjects.Add _
(ClassType:="Forms.ComboBox.1", _
Link:=False, DisplayAsIcon:=False, _
Left:=.Left, Top:=.Top, Width:=.Width, _
Height:=.Height)

End With

With myOLEObj
.LinkedCell = .TopLeftCell.Offset(0, 0) _
.Address(external:=True)
.ListFillRange = Worksheets("Linked Cells").Range
("g2:g9") _
.Address(external:=True)
.Placement = xlMoveAndSize
End With
Next myCell
End With

 

[Dave Peterson]

One way:

Option Explicit
Sub testme01()

Dim myOLEObj As OLEObject
Dim myRng As Range
Dim myCell As Range

With ActiveSheet
Set myRng = .Range("b22:b33")
End With

For Each myCell In myRng.Cells
With myCell
If IsEmpty(.Offset(0, -1)) Then
'done.
Exit For
Else
Set myOLEObj = .Parent.OLEObjects.Add _
(ClassType:="Forms.ComboBox.1", _
Link:=False, DisplayAsIcon:=False, _
Left:=.Left, Top:=.Top, Width:=.Width, _
Height:=.Height)
End If
End With

With myOLEObj
.Object.BackColor = &HFFFF&
.LinkedCell = .TopLeftCell.Address(external:=True)
.ListFillRange = Worksheets("Linked Cells") _
.Range("g2:g9").Address(external:=True)
.Placement = xlMoveAndSize
End With

Next myCell

End Sub

 

[LB]

Thanks for your prompt reply. I've copied your code into my macro.
The yellow highlighting part worked great, but it's still copying the
combo box next to every cell even if it's blank. I have another macro
that runs first that puts the following formula into the respective
cells in column A then hardcodes the values to get rid of the formulas
that didn't bring back a result:

Range("A23").Select
Selection.FormulaArray = _

"=IF(R20C=""Closed"","""",IF(iserror(INDEX(Range2,SMALL(IF(Range1=Name&R20C,ROW(Schedules!R1:R77)),ROW(Schedules!R[-22])),4)),"""",INDEX(Range2,SMALL(IF(Range1=Name&Template!R20C,ROW(Schedules!R1:R77)),ROW(Schedules!R[-22])),4)))"
Range("A23").Select
Application.CutCopyMode = False
Selection.Copy
Range("A23,C23,E23,G23,I23"). _
Select
Range("i23").Activate
ActiveSheet.Paste
Rows("23:23").Select
Selection.Copy
Range("A24:A34").Select
ActiveSheet.Paste

Rows("23:34").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

It doesn't seem to be recognizing the blank cells in column A. Please
help!!!!

 

[Dave Peterson]

First, I read the posts in plain text--I connect to the newsservers
directly--not through excelforum.

Second, your cells that evaluated to "" and were converted to values aren't
blank!

Try using:
=ISBLANK(A1)
(and point at one of those cells)

But you can check for the length of what's in the cell.

This is the line that would change:

If IsEmpty(.Offset(0, -1)) Then
to
if .offset(0,-1).value = "" then

====
Ps. When I really have to have empty cells for those "" converted to values,
I'll do this:

Select the range
edit|replace
what: (leave blank)
with: $$$$$
replace all

then reverse it:
edit|replace
what: $$$$$
with: (leave blank)
replace all

It means that the cell is now really blank. (Test it with =isblank().)

Thanks for your prompt reply. I've copied your code into my macro.
The yellow highlighting part worked great, but it's still copying the
combo box next to every cell even if it's blank. I have another macro
that runs first that puts the following formula into the respective
cells in column A then hardcodes the values to get rid of the formulas
that didn't bring back a result:

Range("A23").Select
Selection.FormulaArray = _

"=IF(R20C=""Closed"","""",IF(iserror(INDEX(Range2,SMALL(IF(Range1=Name&R20C,ROW(Schedules!R1:R77)),ROW(Schedules!R[-22])),4)),"""",INDEX(Range2,SMALL(IF(Range1=Name&Template!R20C,ROW(Schedules!R1:R77)),ROW(Schedules!R[-22])),4)))"
Range("A23").Select
Application.CutCopyMode = False
Selection.Copy
Range("A23,C23,E23,G23,I23"). _
Select
Range("i23").Activate
ActiveSheet.Paste
Rows("23:23").Select
Selection.Copy
Range("A24:A34").Select
ActiveSheet.Paste

Rows("23:34").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

It doesn't seem to be recognizing the blank cells in column A. Please
help!!!!

 

[LB]

Thanks so much, Dave, for the prompt replies and the great advice.
Most everything works like a charm now. I'm struggling to find the
perfect code to be able to send my file via e-mail without getting a
warning that Outlook Express is blocking a potentially unsafe
attachment. I'll start a new thread for this problem, though! Thanks
again, Dave.