I have the following code (from Dave Peterson) which populates a shape by
reading a range of cells (range name: SCLIST) that is 2 columns wide by a
varying # of rows long. This code works wonderfully; the only thing I would
like to know is, is it possible to adjust the code so that when the shape is
visible, you don't see blank rows in the data source range. For example,
suppose my list has no data in Rows 3 and 4, then I don't want those blank
rows in the shape; i.e., I need Row 5 'moved up' to just below Row 2.
Suppose I could do it in a round-about way by copying the data over to
another area and removing the blank area, but thought maybe the existing code
could be tweaked to do this. If anyone can help, it would be appreciate -
thanks....Paige

Data source looks like this, and so does text in shape:
Col A Col B
Row 1 SD Onsite 24x7x4 SD
Row 2 NBD Onsite 9x5 NBD
Row 3
Row 4
Row 5 SB Special Bid

Would like the text in the shape to look like this:
Col A Col B
Row 1 SD Onsite 24x7x4 SD
Row 2 NBD Onsite 9x5 NBD
Row 3 SB Special Bid

Dim shp As Shape
Dim sText As String
Dim sLine As String
Dim mySubStr As String
Dim myCell As Range
Dim myRng As Range
Dim myRow As Range
Dim iCtr As Long
If Not (Intersect(Target, Range("L2:L65536")) Is Nothing) Then
With Target
Set shp = Me.shapes("Rectangle 314")
Set myRng = Worksheets("Miscellaneous").Range("SCLIST")
sText = ""
For Each myRow In myRng.Rows
sLine = ""
For Each myCell In myRow.Cells
sLine = sLine & " " & myCell.Text
Next myCell
sText = sText & Mid(sLine, 2) & vbLf
Next myRow
iCtr = 1
Do While iCtr < Len(sText)
mySubStr = Mid(sText, iCtr, 250)
shp.TextFrame.Characters(iCtr).Insert String:=mySubStr
iCtr = iCtr + 250
Loop
With shp
With Worksheets("Miscellaneous")
Set MCrng = Range(Range("A12"), Range("A12").End(xlDown))
End With
.Height = MCrng.Count * 0.0021
.Width = 170
.Top = ActiveCell.Top
.Left = ActiveCell.Left + ActiveCell.Width
End With
shp.Visible = True
End With
Set shp = Nothing
Set myRng = Nothing
Set MCrng = Nothing
Else: Me.shapes("Rectangle 314").Visible = False
End If

This portion could change:

For Each myRow In myRng.Rows
sLine = ""
For Each myCell In myRow.Cells
sLine = sLine & " " & myCell.Text
Next myCell
if trim(sline) = "" then
'nothing in that row
else
sText = sText & Mid(sLine, 2) & vbLf
end if
Next myRow

This actually has a slight problem. If your cells in any row contain space
characters (and nothing more), then that row would be skipped. But I bet that's
not too much of a problem.



Paige wrote:

I have the following code (from Dave Peterson) which populates a shape by
reading a range of cells (range name: SCLIST) that is 2 columns wide by a
varying # of rows long. This code works wonderfully; the only thing I would
like to know is, is it possible to adjust the code so that when the shape is
visible, you don't see blank rows in the data source range. For example,
suppose my list has no data in Rows 3 and 4, then I don't want those blank
rows in the shape; i.e., I need Row 5 'moved up' to just below Row 2.
Suppose I could do it in a round-about way by copying the data over to
another area and removing the blank area, but thought maybe the existing code
could be tweaked to do this. If anyone can help, it would be appreciate -
thanks....Paige

Data source looks like this, and so does text in shape:
Col A Col B
Row 1 SD Onsite 24x7x4 SD
Row 2 NBD Onsite 9x5 NBD
Row 3
Row 4
Row 5 SB Special Bid

Would like the text in the shape to look like this:
Col A Col B
Row 1 SD Onsite 24x7x4 SD
Row 2 NBD Onsite 9x5 NBD
Row 3 SB Special Bid

Dim shp As Shape
Dim sText As String
Dim sLine As String
Dim mySubStr As String
Dim myCell As Range
Dim myRng As Range
Dim myRow As Range
Dim iCtr As Long
If Not (Intersect(Target, Range("L2:L65536")) Is Nothing) Then
With Target
Set shp = Me.shapes("Rectangle 314")
Set myRng = Worksheets("Miscellaneous").Range("SCLIST")
sText = ""
For Each myRow In myRng.Rows
sLine = ""
For Each myCell In myRow.Cells
sLine = sLine & " " & myCell.Text
Next myCell
sText = sText & Mid(sLine, 2) & vbLf
Next myRow
iCtr = 1
Do While iCtr < Len(sText)
mySubStr = Mid(sText, iCtr, 250)
shp.TextFrame.Characters(iCtr).Insert String:=mySubStr
iCtr = iCtr + 250
Loop
With shp
With Worksheets("Miscellaneous")
Set MCrng = Range(Range("A12"), Range("A12").End(xlDown))
End With
.Height = MCrng.Count * 0.0021
.Width = 170
.Top = ActiveCell.Top
.Left = ActiveCell.Left + ActiveCell.Width
End With
shp.Visible = True
End With
Set shp = Nothing
Set myRng = Nothing
Set MCrng = Nothing
Else: Me.shapes("Rectangle 314").Visible = False
End If

--

Dave Peterson

Wow - works great! Thanks again, Dave. Have a good evening....

"Dave Peterson" wrote:

This portion could change:

For Each myRow In myRng.Rows
sLine = ""
For Each myCell In myRow.Cells
sLine = sLine & " " & myCell.Text
Next myCell
if trim(sline) = "" then
'nothing in that row
else
sText = sText & Mid(sLine, 2) & vbLf
end if
Next myRow

This actually has a slight problem. If your cells in any row contain space
characters (and nothing more), then that row would be skipped. But I bet that's
not too much of a problem.



Paige wrote:

I have the following code (from Dave Peterson) which populates a shape by
reading a range of cells (range name: SCLIST) that is 2 columns wide by a
varying # of rows long. This code works wonderfully; the only thing I would
like to know is, is it possible to adjust the code so that when the shape is
visible, you don't see blank rows in the data source range. For example,
suppose my list has no data in Rows 3 and 4, then I don't want those blank
rows in the shape; i.e., I need Row 5 'moved up' to just below Row 2.
Suppose I could do it in a round-about way by copying the data over to
another area and removing the blank area, but thought maybe the existing code
could be tweaked to do this. If anyone can help, it would be appreciate -
thanks....Paige

Data source looks like this, and so does text in shape:
Col A Col B
Row 1 SD Onsite 24x7x4 SD
Row 2 NBD Onsite 9x5 NBD
Row 3
Row 4
Row 5 SB Special Bid

Would like the text in the shape to look like this:
Col A Col B
Row 1 SD Onsite 24x7x4 SD
Row 2 NBD Onsite 9x5 NBD
Row 3 SB Special Bid

Dim shp As Shape
Dim sText As String
Dim sLine As String
Dim mySubStr As String
Dim myCell As Range
Dim myRng As Range
Dim myRow As Range
Dim iCtr As Long
If Not (Intersect(Target, Range("L2:L65536")) Is Nothing) Then
With Target
Set shp = Me.shapes("Rectangle 314")
Set myRng = Worksheets("Miscellaneous").Range("SCLIST")
sText = ""
For Each myRow In myRng.Rows
sLine = ""
For Each myCell In myRow.Cells
sLine = sLine & " " & myCell.Text
Next myCell
sText = sText & Mid(sLine, 2) & vbLf
Next myRow
iCtr = 1
Do While iCtr < Len(sText)
mySubStr = Mid(sText, iCtr, 250)
shp.TextFrame.Characters(iCtr).Insert String:=mySubStr
iCtr = iCtr + 250
Loop
With shp
With Worksheets("Miscellaneous")
Set MCrng = Range(Range("A12"), Range("A12").End(xlDown))
End With
.Height = MCrng.Count * 0.0021
.Width = 170
.Top = ActiveCell.Top
.Left = ActiveCell.Left + ActiveCell.Width
End With
shp.Visible = True
End With
Set shp = Nothing
Set myRng = Nothing
Set MCrng = Nothing
Else: Me.shapes("Rectangle 314").Visible = False
End If

--

Dave Peterson