M
mikebres
I tried to setup a UDF that would show detail information about an ID number.
I could click on the number and a comment would popup with the info. Worked
really nice, until I tried to run another macro to add banding to the sheet.
My first macro used the SelectionChange event to trigger it. My second
macro changes the selection to do the banding, so now it triggers the first
macro for each change in selection. It slowed it down to a crawl. Here are
both UDFs. Does anybody have a suggestion on how to make them work together?
Thanks - Mike
The banding UDF:
Sub Banding()
Dim TempRow As String
Dim varBackColor As Long
Dim OnOff As Boolean
vColor = ActiveCell.Interior.ColorIndex
'Get rid of any empty rows so the range selection will work
'Call DeleteEmptyRows
'To get rid of the annoying screen flicker and speed it up
Application.ScreenUpdating = False
'Setup the selection and Get a count of the rows & columns
Range("A1").Select
Selection.CurrentRegion.Select
cCol = Selection.Columns.Count
cRows = Selection.Rows.Count
TempRow = InputBox("Which row do you want to compare?")
'Can input either the column label,or the number of the column
If Application.WorksheetFunction.IsNumber(TempRow) Then
WhichColumn = TempRow
ElseIf Application.WorksheetFunction.IsText(TempRow) Then
WhichColumn = Asc(StrConv(TempRow, 1)) - 64
End If
'Walk through the list
eRow = 2: sRow = 2
OnOff = True
For i = 2 To cRows
Range(Cells(i, WhichColumn), Cells(i, cCol)).Select
If Cells(i, WhichColumn) <> Cells(i + 1, WhichColumn) Then
eRow = ActiveCell.Row
Range(Cells(sRow, 1), Cells(eRow, cCol)).Select
If OnOff Then
With Selection.Interior
.ColorIndex = vColor
.Pattern = xlSolid
ChooseBorders (15)
End With
OnOff = False
Else
With Selection.Interior
.ColorIndex = xlNone
End With
OnOff = True
End If
sRow = eRow + 1
End If
Next
'Turn Screen update back on
Application.ScreenUpdating = True
End Sub
The comment box UDF:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'* Subroutine to display a comment with the decoded information from
'* the FICS barcode ID Tag. This only decodes ID Tags that start with
'* J18CUSA. Other formats won't be decoded. This module should be loaded
'* into the Selection_Change event of the worksheet. That way it will
activate
'* whenever you select a new cell.
Dim fString As String, X As String
Dim cmt As Comment
'Clear out the other comments so we don't get a clutter of comments
Application.ScreenUpdating = False 'Turn off screen updates to
speed it up
For Each cmt In ActiveSheet.Comments
cmt.Delete
Next
'Add the comment
If Target.Count = 1 Then 'Make sure only one cell is
selected
If Left(Target.Value, 7) = "J18CUSA" Then 'Make sure the cell has
the FICS barcode info
X = Target.Value
vSerial = Mid(X, 8, 3)
vDecSerial = CLng("&H" & vSerial)
vPriority = Mid(X, 11, 1)
vMonth = Mid(X, 12, 2)
vDay = Mid(X, 14, 2)
vHour = Mid(X, 16, 2)
vMinute = Mid(X, 18, 2)
vMSTDateTime = DateAdd("h", -7, DateSerial(Year(Now()), vMonth,
vDay) + TimeSerial(vHour, vMinute, 0))
vDate = FormatDateTime(DateSerial(Year(Now()), vMonth, vDay),
vbShortDate)
vTime = FormatDateTime(TimeSerial(vHour, vMinute, 0), vbShortTime)
vMSTDate = FormatDateTime(vMSTDateTime, vbShortDate)
vMSTTime = FormatDateTime(vMSTDateTime, vbShortTime)
Select Case vDecSerial
Case 53: vLocal = 1
Case 72: vLocal = 2
Case 95: vLocal = 3
Case 114: vLocal = 4
Case 162: vLocal = 5
Case 2044: vLocal = 6
Case 2068: vLocal = 7
Case 2346: vLocal = 8
End Select
fString = "Date/Time: " & vDate & " " & vTime & " GMT" & vbLf & _
"Date/Time: " & vMSTDate & " " & vMSTTime & " MST" & vbLf & _
"Machine: " & vDecSerial & " Local#: " & vLocal & vbLf & _
"Priority: " & vPriority
Target.AddComment.Text Text:=fString
With Target.Comment
.Shape.TextFrame.AutoSize = True
.Shape.Width = 250
.Shape.Height = 75
.Shape.TextFrame.Characters.Font.Size = 14
End With
'Format the labels with Bold
Target.Comment.Shape.TextFrame.Characters(1, 10).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(33, 10).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(65, 8).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(77, 8).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(88, 9).Font.Bold = True
End If
End If
Application.ScreenUpdating = True 'Turn it back on so we can see
use the screen
End Sub
I could click on the number and a comment would popup with the info. Worked
really nice, until I tried to run another macro to add banding to the sheet.
My first macro used the SelectionChange event to trigger it. My second
macro changes the selection to do the banding, so now it triggers the first
macro for each change in selection. It slowed it down to a crawl. Here are
both UDFs. Does anybody have a suggestion on how to make them work together?
Thanks - Mike
The banding UDF:
Sub Banding()
Dim TempRow As String
Dim varBackColor As Long
Dim OnOff As Boolean
vColor = ActiveCell.Interior.ColorIndex
'Get rid of any empty rows so the range selection will work
'Call DeleteEmptyRows
'To get rid of the annoying screen flicker and speed it up
Application.ScreenUpdating = False
'Setup the selection and Get a count of the rows & columns
Range("A1").Select
Selection.CurrentRegion.Select
cCol = Selection.Columns.Count
cRows = Selection.Rows.Count
TempRow = InputBox("Which row do you want to compare?")
'Can input either the column label,or the number of the column
If Application.WorksheetFunction.IsNumber(TempRow) Then
WhichColumn = TempRow
ElseIf Application.WorksheetFunction.IsText(TempRow) Then
WhichColumn = Asc(StrConv(TempRow, 1)) - 64
End If
'Walk through the list
eRow = 2: sRow = 2
OnOff = True
For i = 2 To cRows
Range(Cells(i, WhichColumn), Cells(i, cCol)).Select
If Cells(i, WhichColumn) <> Cells(i + 1, WhichColumn) Then
eRow = ActiveCell.Row
Range(Cells(sRow, 1), Cells(eRow, cCol)).Select
If OnOff Then
With Selection.Interior
.ColorIndex = vColor
.Pattern = xlSolid
ChooseBorders (15)
End With
OnOff = False
Else
With Selection.Interior
.ColorIndex = xlNone
End With
OnOff = True
End If
sRow = eRow + 1
End If
Next
'Turn Screen update back on
Application.ScreenUpdating = True
End Sub
The comment box UDF:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'* Subroutine to display a comment with the decoded information from
'* the FICS barcode ID Tag. This only decodes ID Tags that start with
'* J18CUSA. Other formats won't be decoded. This module should be loaded
'* into the Selection_Change event of the worksheet. That way it will
activate
'* whenever you select a new cell.
Dim fString As String, X As String
Dim cmt As Comment
'Clear out the other comments so we don't get a clutter of comments
Application.ScreenUpdating = False 'Turn off screen updates to
speed it up
For Each cmt In ActiveSheet.Comments
cmt.Delete
Next
'Add the comment
If Target.Count = 1 Then 'Make sure only one cell is
selected
If Left(Target.Value, 7) = "J18CUSA" Then 'Make sure the cell has
the FICS barcode info
X = Target.Value
vSerial = Mid(X, 8, 3)
vDecSerial = CLng("&H" & vSerial)
vPriority = Mid(X, 11, 1)
vMonth = Mid(X, 12, 2)
vDay = Mid(X, 14, 2)
vHour = Mid(X, 16, 2)
vMinute = Mid(X, 18, 2)
vMSTDateTime = DateAdd("h", -7, DateSerial(Year(Now()), vMonth,
vDay) + TimeSerial(vHour, vMinute, 0))
vDate = FormatDateTime(DateSerial(Year(Now()), vMonth, vDay),
vbShortDate)
vTime = FormatDateTime(TimeSerial(vHour, vMinute, 0), vbShortTime)
vMSTDate = FormatDateTime(vMSTDateTime, vbShortDate)
vMSTTime = FormatDateTime(vMSTDateTime, vbShortTime)
Select Case vDecSerial
Case 53: vLocal = 1
Case 72: vLocal = 2
Case 95: vLocal = 3
Case 114: vLocal = 4
Case 162: vLocal = 5
Case 2044: vLocal = 6
Case 2068: vLocal = 7
Case 2346: vLocal = 8
End Select
fString = "Date/Time: " & vDate & " " & vTime & " GMT" & vbLf & _
"Date/Time: " & vMSTDate & " " & vMSTTime & " MST" & vbLf & _
"Machine: " & vDecSerial & " Local#: " & vLocal & vbLf & _
"Priority: " & vPriority
Target.AddComment.Text Text:=fString
With Target.Comment
.Shape.TextFrame.AutoSize = True
.Shape.Width = 250
.Shape.Height = 75
.Shape.TextFrame.Characters.Font.Size = 14
End With
'Format the labels with Bold
Target.Comment.Shape.TextFrame.Characters(1, 10).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(33, 10).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(65, 8).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(77, 8).Font.Bold = True
Target.Comment.Shape.TextFrame.Characters(88, 9).Font.Bold = True
End If
End If
Application.ScreenUpdating = True 'Turn it back on so we can see
use the screen
End Sub