UserForm past data

[Patrick C. Simonds]

I have a series of cells on a worksheet which when clicked on open a
DialogBox. The DialogBox has ListBox which references another worksheet in
the same workbook, when I click OK it deposits the ListBox value into the
triggering cell. All of this works great, except, I also need to maintain
the font formatting (color) when it places the value in the triggering cell.
Is there any way to modify the code below to accomplish this?






Private Sub CommandButton1_Click()

'This UserForm is used to populate the Operator to Cover section of the
worksheet

On Error GoTo EndMacro

Friday_Routes_to_Cover.Hide
DoEvents

Dim rng

Set rng = Cells(ActiveCell.Row, 1)

rng(1, 4).Value = ListBox1.List(ListBox1.ListIndex, 0)
rng(1, 7).Value = ListBox1.List(ListBox1.ListIndex, 1)
rng(1, 10).Value = ListBox1.List(ListBox1.ListIndex, 2)
rng(1, 13).Value = ListBox1.List(ListBox1.ListIndex, 3)

rng(1, 6).Value = ListBox1.List(ListBox1.ListIndex, 13)
rng(1, 9).Value = ListBox1.List(ListBox1.ListIndex, 14)
rng(1, 12).Value = ListBox1.List(ListBox1.ListIndex, 15)
rng(1, 15).Value = ListBox1.List(ListBox1.ListIndex, 16)


Unload Friday_Routes_to_Cover

EndMacro:

Unload Friday_Routes_to_Cover

End Sub

 

[Peter T]

From just looking at your code I can't see why dumping values to cells
should change any formats (other than mixed formats if that's what you
have).

However if I'm missing something, trap the colorindex of the font in the
active cell (triggering cell?) and re-apply when done.

fntClrIdx = activecell.font.colorindex
'code
' when done
activecell.font.colorindex = fntClrIdx

Regards,
Peter T

 

[Patrick C. Simonds]

I am sorry I was not clear.

The data in the row source for the ListBox is contained on another
worksheet. That data's font has a color based upon certain variables. When
that data is deposited into the triggering cell, I need it to be the same
color as it was on the source worksheet.

 

[Peter T]

OK that's a bit clearer, but not much.

Following just a guess of what you want to achieve based on what you posted.
Looks like your rowsource has at least 17 columns; this should apply same
colour font to the various destination cells as applied in the respective
data cells. Like I said, it's only a guess, adapt as required.


Private Sub CommandButton1_Click()
Dim i As Long, nRow As Long, nLstIdx As Long
Dim rngList As Range
Dim aCols, aLstCols

aCols = Array(4, 7, 10, 13, 6, 9, 12, 15)
aLstCols = Array(0, 1, 2, 3, 13, 14, 15, 16)

Set rngList = Range(Me.ListBox1.RowSource)
nRow = ActiveCell.Row
nLstIdx = Me.ListBox1.ListIndex

If nRow > Me.ListBox1.ListCount Or nLstIdx = -1 Then
MsgBox "activecell row out of range or no list row selected"
Exit Sub
End If

For i = 0 To UBound(aCols)
With Cells(nRow, aCols(i))
.Value = ListBox1.List(nLstIdx, aLstCols(i))
.Font.ColorIndex = rngList(nLstIdx + 1, aLstCols(i) + 1)
End With
Next

End Sub

Regards,
Peter T

 

[Patrick C. Simonds]

Thank you, but I get a Type Mismatch error on the following line:

..Font.ColorIndex = rngList(nLstIdx + 1, aLstCols(i) + 1)

 

[Peter T]

Somehow an important bit got lost in the posting, change

.Font.ColorIndex = rngList(nLstIdx + 1, aLstCols(i) + 1)

to
..Font.ColorIndex = rngList(nLstIdx + 1, aLstCols(i) + 1).Font.ColorIndex

As written, font colorIndex of the row(nLstIdx + 1), column(aLstCols(i) + 1)
of the rowsource range is applied to the cell receiving the data.

Regards,
Peter T

 

[Patrick C. Simonds]

Thank you very much, that was great.

I did have to remove the following code, because it would always tel me that "activecell row out of range or no list row selected"

If nRow > Me.ListBox1.ListCount Or nLstIdx = -1 Then
MsgBox "activecell row out of range or no list row selected"
Exit Sub
End If

Is there any way to incorporate the remaining (green) code below? Those values are pasted in the row below.




Private Sub CommandButton1_Click()

'Friday_Route_Selection.Hide

Dim i As Long, nRow As Long, nLstIdx As Long
Dim rngList As Range
Dim aCols, aLstCols

aCols = Array(4, 7, 10, 13, 6, 9, 12, 15)
aLstCols = Array(0, 1, 2, 3, 13, 14, 15, 16)

Set rngList = Range(Me.ListBox1.RowSource)
nRow = ActiveCell.Row
nLstIdx = Me.ListBox1.ListIndex



For i = 0 To UBound(aCols)
With Cells(nRow, aCols(i))
.Value = ListBox1.List(nLstIdx, aLstCols(i))
.Font.ColorIndex = rngList(nLstIdx + 1, aLstCols(i) + 1).Font.ColorIndex
End With
Next

rng(2, 4).Value = ListBox1.List(ListBox1.ListIndex, 4)
rng(2, 5).Value = ListBox1.List(ListBox1.ListIndex, 5)
rng(2, 7).Value = ListBox1.List(ListBox1.ListIndex, 6)
rng(2, 8).Value = ListBox1.List(ListBox1.ListIndex, 7)
rng(2, 10).Value = ListBox1.List(ListBox1.ListIndex, 8)
rng(2, 11).Value = ListBox1.List(ListBox1.ListIndex, 9)
rng(2, 13).Value = ListBox1.List(ListBox1.ListIndex, 10)
rng(2, 14).Value = ListBox1.List(ListBox1.ListIndex, 11)

End Sub

 

[Peter T]

I'm surprised the code works if you remove the initial test, actually two
tests

If nRow > Me.ListBox1.ListCount then

If nRow, ie activecell row is more than the number of rows in your list the
rest of the code would fail (unless I've missed something).

If nLstIdx = -1 then
nLstIdx, ie .ListIndex = -1 indicates User has not selected a list row. The
list index is used to extract values so again it would fail, I would have
thought.

It might be worth splitting into two separate tests to determine which is
failing.


Looks like you have a second batch of data (greens ?) to dump in a similar
fashion in the row below the active row. Under the 1st loop make two new
arrays just like the first two with appropriate values,

aCols = Array(4, 5, 7, etc
aLstCols = Array(4, 5, 6, etc

and just below virtually the same loop

For i = 0 To UBound(aCols)
With Cells(nRow + 1, aCols(i))
.Value = ListBox1.List(nLstIdx, aLstCols(i))
.Font.ColorIndex = rngList(nLstIdx + 1, aLstCols(i) +
1).Font.ColorIndex
End

Notice the difference,
1st loop:With Cells(nRow, aCols(i))
2nd loop: With Cells(nRow, aCols(i))
ie, row below active row.

With the new code in place you should be able to remove your following code.

If you haven't already, it would be worth figuring how the code I've
suggested works, both to ensure it correctly does what you want and to make
simple modifications.

Regards,
Peter T

PS, In my newsreader your post appears with an attachment which was disabled


Thank you very much, that was great.

I did have to remove the following code, because it would always tel me that
"activecell row out of range or no list row selected"

If nRow > Me.ListBox1.ListCount Or nLstIdx = -1 Then
MsgBox "activecell row out of range or no list row selected"
Exit Sub
End If

Is there any way to incorporate the remaining (green) code below? Those
values are pasted in the row below.




Private Sub CommandButton1_Click()

'Friday_Route_Selection.Hide

Dim i As Long, nRow As Long, nLstIdx As Long
Dim rngList As Range
Dim aCols, aLstCols

aCols = Array(4, 7, 10, 13, 6, 9, 12, 15)
aLstCols = Array(0, 1, 2, 3, 13, 14, 15, 16)

Set rngList = Range(Me.ListBox1.RowSource)
nRow = ActiveCell.Row
nLstIdx = Me.ListBox1.ListIndex



For i = 0 To UBound(aCols)
With Cells(nRow, aCols(i))
.Value = ListBox1.List(nLstIdx, aLstCols(i))
.Font.ColorIndex = rngList(nLstIdx + 1, aLstCols(i) +
1).Font.ColorIndex
End With
Next

rng(2, 4).Value = ListBox1.List(ListBox1.ListIndex, 4)
rng(2, 5).Value = ListBox1.List(ListBox1.ListIndex, 5)
rng(2, 7).Value = ListBox1.List(ListBox1.ListIndex, 6)
rng(2, 8).Value = ListBox1.List(ListBox1.ListIndex, 7)
rng(2, 10).Value = ListBox1.List(ListBox1.ListIndex, 8)
rng(2, 11).Value = ListBox1.List(ListBox1.ListIndex, 9)
rng(2, 13).Value = ListBox1.List(ListBox1.ListIndex, 10)
rng(2, 14).Value = ListBox1.List(ListBox1.ListIndex, 11)

End Sub