VBA Snippets
Address_ColumnLetter
Returns the column letter from a cell address containing a column and a row.source code
Cell_LastDataRow
Public Function Cell_LastDataRow( _
ByVal sColChar As String, _
ByVal lRowFirst As Long, _
Optional ByVal sWshName As String = "", _
Optional ByVal iNoOfBlanks As Integer = 0, _
Optional ByVal bReturnRowNo As Boolean = True) As Long
Const PROCNAME As String = "Cell_LastDataRow"
Dim lrowcounter As Long
Dim iblankscounter As Integer
On Error GoTo ErrorHandler
' Call Tracer_AddSubroutineStart(msMODULENAME, sProcName)
If (sWshName = "") Then
sWshName = ActiveSheet.Name
End If
lrowcounter = 0
iblankscounter = 0
'Worksheets(sWshName).Range(sColChar & lRowFirst).Select 'select the initial cell
While (iblankscounter < iNoOfBlanks) Or _
(Worksheets(sWshName).Range(sColChar & lRowFirst).Offset(lrowcounter, 0).Text <> "")
If Worksheets(sWshName).Range(sColChar & lRowFirst).Offset(lrowcounter, 0).Text = "" Then
iblankscounter = iblankscounter + 1
lrowcounter = lrowcounter + 1
Else
iblankscounter = 0
lrowcounter = lrowcounter + 1
End If
Wend
If bReturnRowNo = True Then
'returns the start row if there is no data below
If lrowcounter = 0 Then Cell_LastDataRow = (lRowFirst - 1) + lrowcounter
If lrowcounter > 0 Then Cell_LastDataRow = (lRowFirst - 1) + lrowcounter
End If
If bReturnRowNo = False Then
'returns the row above if the start cell is empty
Cell_LastDataRow = lrowcounter
End If
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "G1", "NO")
End Function
Cell_LastPopulatedRow
Public Function Cell_LastPopulatedRow(ByVal sWshname As String, _
ByVal sCellRange As String) As Long
Dim llastrow As Long
llastrow = Worksheets(sWshname).Range(sCellRange).SpecialCells(XlCellType.xlCellTypeLastCell).Row
Cell_LastPopulatedRow = llastrow
End Function
Cell_OffsetFormat
Public Sub Cell_OffsetFormat(ByVal objCell As Excel.Range, _
ByVal iRowOffset As Integer, _
ByVal iColumnOffset As Integer, _
ByVal sText As String, _
ByVal bBold As Boolean, _
Optional ByVal enHAlignment As Excel.XlHAlign = XlHAlign.xlHAlignGeneral, _
Optional ByVal sNumberFormat As String = "")
On Error GoTo AnError
If Len(sNumberFormat) > 0 Then
objCell.Offset(iRowOffset, iColumnOffset).NumberFormat = sNumberFormat
End If
If IsDate(sText) = False Then
objCell.Offset(iRowOffset, iColumnOffset).Value = sText
Else
objCell.Offset(iRowOffset, iColumnOffset).Value = CLng(VBA.DateValue(sText))
End If
objCell.Offset(iRowOffset, iColumnOffset).Font.Bold = bBold
objCell.Offset(iRowOffset, iColumnOffset).HorizontalAlignment = enHAlignment
Exit Sub
AnError:
End Sub
Cell_OffsetInsertRandomNumbers
Public Sub Cell_OffsetInsertRandomNumbers(ByVal objCell As Excel.Range, _
ByVal iNoOfRows As Integer, _
ByVal iNoOfColumns As Integer, _
ByVal dbLowestValue As Double, _
ByVal dbHighestValue As Double, _
ByVal iNoOfDecimals As Integer, _
Optional ByVal bInsertFormula As Boolean = False)
Dim irowcount As Integer
Dim icolcount As Integer
On Error GoTo AnError
For irowcount = 0 To iNoOfRows
For icolcount = 0 To iNoOfColumns
objCell.Offset(irowcount, icolcount) = _
Number_Random(dbLowestValue, dbHighestValue, iNoOfDecimals)
Next icolcount
Next irowcount
Exit Sub
AnError:
End Sub
CellRef_GetColFirst
Public Function CellRef_GetColFirst(ByVal sCompleteReference As String, _
Optional ByVal bIncludeDollar As Boolean = False) As String
Dim sreference As String
Dim icharpos As Integer
Dim bfound As Boolean
On Error GoTo ErrorHandler
sreference = sCompleteReference
bfound = False
If bIncludeDollar = False Then 'remove any preceding dollar
If InStr(sreference, "$") = 1 Then
sreference = Right(sreference, Len(sreference) - 1)
icharpos = 0
End If
End If
Do While (bfound = False) And (icharpos <= Len(sCompleteReference))
icharpos = icharpos + 1
If IsNumeric(Mid(sreference, icharpos, 1)) = True Or _
((Mid(sreference, icharpos, 1) = "$") And _
(IsNumeric(Mid(sreference, icharpos + 1, 1)))) = True Then
bfound = True
End If
Loop
CellRef_GetColFirst = Left(sreference, icharpos - 1)
If icharpos = Len(sCompleteReference) Then
'maybe raise an error ??
'GoTo AnError
End If
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, "CellRef_GetColFirst", Err)
End Function
CellRef_GetColLast
Public Function CellRef_GetColLast(sCompleteReference As String, _
Optional bIncludeDollar As Boolean = False) As String
Const PROCNAME As String = "CellRef_GetColLast"
Dim icolon As Integer
Dim sreference As String
On Error GoTo ErrorHandler
sreference = sCompleteReference
icolon = InStr(sreference, ":")
sreference = Right(sreference, Len(sreference) - icolon)
CellRef_GetLastCol = CellRef_GetFirstCol(sreference, bIncludeDollar)
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GO1", "AD1", _
"last column letter from the reference" & vbCrLf & _
"""" & sCompleteReference & """")
End Function
CellRef_GetRowFirst
Public Function CellRef_GetRowFirst(ByVal sCompleteReference As String, _
Optional ByVal bIncludeDollar As Boolean = False) As String
Dim sreference As String
Dim icolon As Integer
Dim bfound As Boolean
Dim icharpos As Integer
On Error GoTo ErrorHandler
sreference = sCompleteReference
bfound = False
If bIncludeDollar = False Then 'remove any preceding dollar
If InStr(sreference, "$") = 1 Then
sreference = Right(sreference, Len(sreference) - 1)
icharpos = 0
End If
End If
Do While (bfound = False) And (icharpos <= Len(sreference))
icharpos = icharpos + 1
If IsNumeric(Mid(sreference, icharpos, 1)) = True Or _
((Mid(sreference, icharpos, 1) = "$") And _
(IsNumeric(Mid(sreference, icharpos + 1, 1)))) = True Then
bfound = True
End If
Loop 'remove first column
sreference = Right(sreference, Len(sreference) - icharpos + 1)
If bIncludeDollar = False Then 'remove any preceding dollar
If InStr(sreference, "$") = 1 Then _
sreference = Right(sreference, Len(sreference) - 1)
End If
icolon = InStr(sreference, ":")
If icolon = 0 Then 'there is no range of cells
CellRef_GetRowFirst = sreference
Else
CellRef_GetRowFirst = Left(sreference, icolon - 1)
End If
If (icharpos = Len(sCompleteReference)) Then
'maybe raise an error
'GoTo AnError
End If
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, "CellRef_GetRowFirst", Err)
End Function
CellRef_GetRowLast
Public Function CellRef_GetRowLast(ByVal sCompleteReference As String, _
Optional ByVal bIncludeDollar As Boolean = False) As String
Dim sreference As String
Dim icolon As Integer
On Error GoTo AnError
sreference = sCompleteReference
icolon = InStr(sreference, ":")
sreference = Right(sreference, Len(sreference) - icolon)
CellRef_GetRowLast = CellRef_GetRowFirst(sreference, bIncludeDollar)
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_GetRowLast", Err)
End Function
CellRef_HasFolderPath
Public Function CellRef_HasFolderPath(ByVal sCompleteReference As String) As Boolean
Dim icolon As Integer
Dim isquarebracketopen As Integer
On Error GoTo ErrorHandler
icolon = InStr(sCompleteReference, ":")
isquarebracketopen = InStr(sCompleteReference, "[")
If (icolon > 0) And (icolon < isquarebracketopen) Then
CellRef_HasFolderPath = True
Else
CellRef_HasFolderPath = False
End If
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, "CellRef_HasFolderPath", Err)
End Function
CellRef_HasWbkName
Public Function CellRef_HasWbkName(ByVal sCompleteReference As String) As Boolean
Dim isinglespeechmark As Integer
Dim isquarebracketopen As Integer
On Error GoTo ErrorHandler
isinglespeechmark = InStr(sCompleteReference, "'")
isquarebracketopen = InStr(sCompleteReference, "[")
If isinglespeechmark = 1 And isquarebracketopen = 2 Then
CellRef_HasWbkName = True
Else
CellRef_HasWbkName = False
End If
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, "CellRef_HasWbkName", Err)
End Function
CellRef_HasWshName
Public Function CellRef_HasWshName(ByVal sCompleteReference As String) As Boolean
Dim isinglespeechmark As Integer
Dim iexclamationmark As Integer
On Error GoTo ErrorHandler
isinglespeechmark = InStr(sCompleteReference, "'")
iexclamationmark = InStr(sCompleteReference, "!")
If (isinglespeechmark <> 0) Or _
(iexclamationmark <> 0) Then
CellRef_HasWshName = True
Else
CellRef_HasWshName = False
End If
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, "CellRef_HasWshName", Err)
End Function
CellRef_IsItARange
Public Function CellRef_IsItARange(sCompleteReference As String) As Boolean
Const PROCNAME As String = "CellRef_IsItARange"
Dim isquarebracketclose As Integer
Dim ifirstsinglespeechmark As Integer
Dim icolon As Integer
On Error GoTo ErrorHandler
icolon = InStr(sCompleteReference, ":")
'cannot have colons in file names or in sheet names
If icolon <> 0 Then CellRef_IsItARange = True
If icolon = 0 Then CellRef_IsItARange = False
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GD4", "AD1", _
"if there is a range of cells in the reference" & vbCrLf & _
"""" & sCompleteReference & """")
End Function
CellRef_RemovePath
Public Function CellRef_RemovePath(sCompleteReference As String) As String
Const PROCNAME As String = "CellRef_RemovePath"
Dim ifirstsinglespeechmark As Integer
Dim isquarebracketopen As Integer
On Error GoTo AnError
isquarebracketopen = InStr(sCompleteReference, "[")
'need to add a single speech mark at the beginning
CellRef_RemovePath = "'" & Right(sCompleteReference, _
Len(sCompleteReference) - isquarebracketopen + 1)
'also need to remove the extra single speech mark
Exit Function
AnError:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GR1", "AD1", _
"the folder path from the reference" & vbCrLf & _
"""" & sCompleteReference & """")
End Function
CellRef_RemoveWbkName
Public Function CellRef_RemoveWbkName(sCompleteReference As String) As String
Const PROCNAME As String = "CellRef_RemoveWbkName"
Dim isquarebracketclose As Integer
On Error GoTo ErrorHandler
isquarebracketclose = InStr(sCompleteReference, "]")
CellRef_RemoveWbkName = "'" & Right(sCompleteReference, _
Len(sCompleteReference) - isquarebracketclose)
'also need to remove the extra single speech mark
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GR1", "AD1", _
"the workbook name from the reference" & vbCrLf & _
"""" & sCompleteReference & """")
End Function
CellRef_RemoveWshName
Public Function CellRef_RemoveWshName(sCompleteReference As String) As String
Const PROCNAME As String = "CellRef_RemoveWshName"
Dim isquarebracketclose As Integer
Dim ifirstsinglespeechmark As Integer
Dim ifirstexclamation As Integer
On Error GoTo ErrorHandler
ifirstsinglespeechmark = InStr(sCompleteReference, "'")
If ifirstsinglespeechmark <> 1 Then
'wsh name is not in single speech marks - no dodgy chars
ifirstexclamation = InStr(1, sCompleteReference, "!", 1)
CellRef_RemoveWshName = Right(sCompleteReference, _
Len(sCompleteReference) - ifirstexclamation)
Else
'-------------------------------------------
Dim icharpos As Integer
Dim inextexclamationmark As Integer
Dim bfound As Boolean
icharpos = 0
bfound = False
Do While (bfound = False) Or (icharpos = Len(sCompleteReference))
icharpos = icharpos + 1
inextexclamationmark = InStr(icharpos, sCompleteReference, "!")
'check the previous char is a single speech mark
If Str_MiddleOf(sCompleteReference, _
Len(sCompleteReference) + 1 - inextexclamationmark, _
inextexclamationmark - 2) = "'" Then
bfound = True
Else: bfound = False
End If
'check the char before that is not another single speech mark
If (bfound = True) Then
If Str_MiddleOf(sCompleteReference, _
Len(sCompleteReference) + 2 - inextexclamationmark, _
inextexclamationmark - 3) <> "'" Then
bfound = True
Else: bfound = False
End If
End If
Loop
'-------------------------------------------
CellRef_RemoveWshName = Right(sCompleteReference, _
Len(sCompleteReference) - inextexclamationmark)
End If
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GR1", "AD1", _
"the worksheet name from the reference" & vbCrLf & _
"""" & sCompleteReference & """")
End Function
CellRef_ReturnComponent
Public Function CellRef_ReturnComponent(ByVal sCompleteReference As String, _
ByVal sWhichComponent As String) As String
Dim bhas As Boolean
Dim rgecellrange As Excel.Range
Dim sreturn As String
On Error GoTo AnError
sreturn = "Missing"
Select Case sWhichComponent
Case "Folder Path"
bhas = CellRef_HasFolderPath(sCompleteReference)
If (bhas = True) Then
sreturn = CellRef_ReturnFolderPath(sCompleteReference)
End If
Case "Workbook"
bhas = CellRef_HasWbkName(sCompleteReference)
If (bhas = True) Then
sreturn = CellRef_ReturnWbkName(sCompleteReference)
End If
Case "Worksheet"
bhas = CellRef_HasWshName(sCompleteReference)
If (bhas = True) Then
sreturn = CellRef_ReturnWshName(sCompleteReference)
End If
Case "Range"
Set rgecellrange = CellRef_ReturnRange(sCompleteReference)
sreturn = rgecellrange.Address
End Select
CellRef_ReturnComponent = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnComponent", Err)
End Function
CellRef_ReturnFolderPath
Public Function CellRef_ReturnFolderPath(ByVal sCompleteReference As String) As String
Const PROCNAME As String = "CellRef_ReturnFolderPath"
Dim ifirstsinglespeechmark As Integer
Dim isquarebracketopen As Integer
On Error GoTo ErrorHandler
isquarebracketopen = InStr(sCompleteReference, "[")
CellRef_GetPath = Mid(sCompleteReference, 2, isquarebracketopen - 2)
'also need to remove the extra single speech mark
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GO1", "AD1", _
"folder path from the reference" & vbCrLf & _
"""" & sCompleteReference & """")End Function
CellRef_ReturnRange
Public Function CellRef_ReturnRange(ByVal sCompleteReference As String) As String
Dim iexclamationmark As Integer
Dim sreturn As String
On Error GoTo AnError
iexclamationmark = InStr(sCompleteReference, "!")
sreturn = Mid(sCompleteReference, iexclamationmark + 1)
CellRef_ReturnRange = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnRange", Err)
End Function
CellRef_ReturnWbkName
Public Function CellRef_ReturnWbkName(ByVal sCompleteReference As String) As String
Dim isquarebracketopen As Integer
Dim isquarebracketclose As Integer
Dim sreturn As String
On Error GoTo AnError
isquarebracketopen = InStr(sCompleteReference, "[")
isquarebracketclose = InStr(sCompleteReference, "]")
sreturn = Mid(sCompleteReference, isquarebracketopen + 1, isquarebracketclose - isquarebracketopen - 1)
CellRef_ReturnWbkName = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnWbkName", Err)
End Function
Public Function CellRef_GetWbkName(sCompleteReference As String, _
Optional bRemoveExt As Boolean = False) As String
Const PROCNAME As String = "CellRef_GetWbkName"
Dim isquarebracketopen%, isquarebracketclose%
On Error GoTo AnError
isquarebracketopen = InStr(sCompleteReference, "[")
isquarebracketclose = InStr(sCompleteReference, "]")
CellRef_GetWbkName = Str_MiddleOf(sCompleteReference, _
Len(sCompleteReference) - isquarebracketclose + 1, _
isquarebracketopen)
If bRemoveExt = True Then _
CellRef_GetWbkName = Left(sCompleteReference, _
Len(sCompleteReference) - 4) 'as .xls
Exit Function
AnError:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GO1", "AD1", _
"workbook name from the reference" & vbCrLf & _
"""" & sCompleteReference & """")
End Function
CellRef_ReturnWshName
Public Function CellRef_ReturnWshName(ByVal sCompleteReference As String) As String
Dim isquarebracketclose As Integer
Dim iexclamationmark As Integer
Dim isinglespeechmark As Integer
Dim sreturn As String
On Error GoTo AnError
iexclamationmark = InStr(sCompleteReference, "!")
sreturn = Left(sCompleteReference, iexclamationmark - 1)
isquarebracketclose = InStr(sCompleteReference, "]")
If (isquarebracketclose <> 0) Then
sreturn = Mid(sreturn, isquarebracketclose + 1)
End If
sreturn = Replace(sreturn, "'", "")
CellRef_ReturnWshName = sreturn
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "CellRef_ReturnWshName", Err)
End Function
Public Function CellRef_GetWshName(sCompleteReference As String) As String
Const PROCNAME As String = "CellRef_GetWshName"
Dim isquarebracketclose As Integer
Dim ifirstsinglespeechmark As Integer
Dim ifirstexclamation As Integer
On Error GoTo ErrorHandler
ifirstsinglespeechmark = InStr(sCompleteReference, "'")
If ifirstsinglespeechmark <> 1 Then
'wsh name is not in single speech marks - no dodgy chars
ifirstexclamation = InStr(1, sCompleteReference, "!", 1)
CellRef_GetWshName = Left(sCompleteReference, _
ifirstexclamation - 1)
Else
'-------------------------------------------
Dim icharpos%, inextexclamationmark%, bfound As Boolean
icharpos = 0
bfound = False
Do While (bfound = False) Or (icharpos = Len(sCompleteReference))
icharpos = icharpos + 1
inextexclamationmark = InStr(icharpos, sCompleteReference, "!")
'check the previous char is a single speech mark
If Str_MiddleOf(sCompleteReference, _
Len(sCompleteReference) + 1 - inextexclamationmark, _
inextexclamationmark - 2) = "'" Then
bfound = True
Else: bfound = False
End If
'check the char before that is not another single speech mark
If (bfound = True) Then
If Str_MiddleOf(sCompleteReference, _
Len(sCompleteReference) + 2 - inextexclamationmark, _
inextexclamationmark - 3) <> "'" Then
bfound = True
Else: bfound = False
End If
End If
Loop
'-------------------------------------------
CellRef_GetWshName = Str_MiddleOf(sCompleteReference, _
Len(sCompleteReference) - (inextexclamationmark - 1) + 1, 1)
End If
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "GO1", "AD1", _
"worksheet name from the reference" & vbCrLf & _
"""" & sCompleteReference & """")
End Function
Cells_ConseqSame
Public Function Cells_ConseqSame(sColChar As String, _
lRowNo As Long) As Boolean
Const sPROCNAME As String = "Cells_ConseqSame"
Dim stext1 As String
Dim stext2 As String
On Error GoTo ErrorHandler
stext1 = Range(sColChar & lRowNo).Value
stext2 = Range(sColChar & lRowNo + 1).Value
If stext1 = stext2 Then
Cells_ConseqSame = True
Else: If stext1 <> stext2 Then Cells_ConseqSame = False
End If
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"determine if the values in the cells """ & _
sColChar & lRowNo & """ and """ & sColChar & lRowNo + 1 & """ are the same")
End Function
Cells_FindLastDataRow
Public Function Cell_LastDataRow(ByVal sColChar As String, _
ByVal lRowFirst As Long, _
Optional ByVal iNoOfBlanks As Integer = 0, _
Optional ByVal bReturnRowNo As Boolean = True) As Long
Const PROCNAME As String = "Cell_LastDataRow"
Dim lrowcounter As Long
Dim iblankscounter As Integer
On Error GoTo ErrorHandler
lrowcounter = 0
iblankscounter = 0
Range(sColChar & lRowFirst).Select 'select the initial cell
While (iblankscounter < iNoOfBlanks) Or _
(ActiveCell.Offset(lrowcounter, 0).Text <> "")
If ActiveCell.Offset(lrowcounter, 0).Text = "" Then
iblankscounter = iblankscounter + 1
lrowcounter = lrowcounter + 1
Else
iblankscounter = 0
lrowcounter = lrowcounter + 1
End If
Wend
If bReturnRowNo = True Then
'returns the start row if there is no data below
If lrowcounter = 0 Then Cell_LastDataRow = (lRowFirst - 1) + lrowcounter
If lrowcounter > 0 Then Cell_LastDataRow = (lRowFirst - 1) + lrowcounter
End If
If bReturnRowNo = False Then
'returns the row above if the start cell is empty
Cell_LastDataRow = lrowcounter
End If
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, PROCNAME, 2, "G1", "NO")
End Function
Cells_FindReplaceValues
Public Sub Cells_FindReplaceValues(ByVal sFindText As String, _
ByVal sReplaceText As String, _
ByVal sColFirst As String, _
ByVal lRowFirst As Long, _
Optional ByVal sColLast As String = "", _
Optional ByVal lRowLast As Long = 0, _
Optional ByVal iNoOfCols As Integer = 0, _
Optional ByVal lNoOfRows As Long = 0)
Const sPROCNAME As String = "Cells_FindReplaceValues"
Dim lrownumber As Long
Dim icolumnnumber As Integer
On Error GoTo ErrorHandler
For icolumnnumber = Col_Number(sColFirst) To Col_Number(sColLast)
For lrownumber = lRowFirst To lRowLast
If Cells(lrownumber, icolumnnumber).Value = sFindText Then _
Cells(lrownumber, icolumnnumber).Value = sReplaceText
Next lrownumber
Next icolumnnumber
Exit Sub
ErrorHandler:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"cells in the range " & _
"""" & sColFirst & lRowFirst & ":" & sColLast & lRowLast & """" & _
" that contain """ & sFindText & """" & _
" and replace them with """ & sReplaceText & """")
End Sub
Cells_Shade
Public Sub Cells_Shade( _
ByVal sWshName As String, _
ByVal lColFirst As Long, _
ByVal lRowFirst As Long, _
ByVal lColLast As Long, _
ByVal lRowLast As Long, _
ByVal lColor As Long)
Const sPROCNAME As String = "Cells_Shade"
Dim oStartCell As Range
Dim oFinishCell As Range
Dim oRange As Range
On Error GoTo ErrorHandler
Set oStartCell = Worksheets(sWshName).Cells(lRowFirst, lColFirst)
Set oFinishCell = Worksheets(sWshName).Cells(lRowLast, lColLast)
Set oRange = Worksheets(sWshName).Range(oStartCell.Address & ":" & oFinishCell.Address)
With oRange.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = lColor
End With
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Cells_ToPicture
Public Sub Cells_ToPicture(SourceRange As Range, FilePathName As String)
Const sProcName As String = "SaveRangePic"
Dim IID_IDispatch As GUID
Dim uPicInfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
On Error GoTo ErrorHandler
SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPtr
.hPal = 0
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
stdole.SavePicture IPic, FilePathName
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sProcName, Err.Number, Err.Description)
End Sub
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Cells_ToStrUnique
Public Function Cells_ToStrUnique( _
ByVal sColChar As String, _
ByVal lRowFirst As Long, _
ByVal lRowLast As Long, _
Optional sSeperatorChar As String = ";") As String
Const sPROCNAME As String = "Cells_ToStrUnique"
Dim lRowNo As Long
Dim stemp As String
On Error GoTo ErrorHandler
lRowNo = lRowFirst
' stemp = Range(sColChar & lRowFirst).Value & sSeperatorChar
With Range(sColChar & lRowFirst)
While (lRowNo <= lRowLast)
If (.Offset(lRowNo - lRowFirst, 0).Value <> "" And _
(Cells_ConseqSame(sColChar, lRowNo) = False)) Then
If Str_ExistsStrConCat(.Offset(lRowNo - lRowFirst, 0).Value, _
stemp, sSeperatorChar) = False Then _
stemp = stemp & .Offset(lRowNo - lRowFirst, 0).Value & sSeperatorChar
End If
lRowNo = lRowNo + 1
Wend
End With
If InStr(stemp, sSeperatorChar) > 0 Then stemp = Left(stemp, Len(stemp) - 1)
Cells_ToStrUnique = stemp
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Function
Public Function Cells_ToStrUnique( _
ByVal sColChar As String, _
ByVal lRowFirst As Long, _
ByVal lrowlast As Long, _
Optional ByVal sSeperatorChar As String = ";") As String
Const sPROCNAME As String = "Cells_ToStrUnique"
Dim lRowNo As Long
Dim scellvalue As String
Dim colUniqueValues As Collection
On Error GoTo ErrorHandler
Set colUniqueValues = New Collection
lRowNo = lRowFirst
While (lRowNo <= lrowlast)
scellvalue = Range(sColChar & lRowFirst).Offset(lRowNo - lRowFirst, 0).Value
If (Collection_ItemExists(colUniqueValues, scellvalue) = False) Then
Call colUniqueValues.Add(scellvalue, scellvalue)
End If
Wend
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
Cells_UniqueValues
Public Function Cells_UniqueValues( _
ByVal rgeTableRange As Excel.Range, _
ByVal iColumnNo As Integer, _
Optional bRemoveErrors As Boolean = True) As Variant
Const sPROCNAME As String = "Cells_UniqueValues"
Dim columnrange As Range
Dim vReturn As Variant
Dim larrayno As Long
On Error GoTo ErrorHandler
Set columnrange = rgeTableRange.Columns(iColumnNo)
vReturn = Application.WorksheetFunction.Unique(columnrange)
vReturn = Application.WorksheetFunction.Transpose(vReturn)
If (bRemoveErrors = True) Then
For larrayno = LBound(vReturn) To UBound(vReturn)
If (VBA.IsError(vReturn(larrayno)) = True) Then
vReturn(larrayno) = ""
End If
Next larrayno
End If
Cells_UniqueValues = vReturn
Exit Function
ErrorHandler:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Function
Message_NoDataRangeHas2BlankCells
Public Sub Message_NoDataRangeHas2BlankCells()
Dim sMessage As String
sMessage = "This is not a valid selection." & _
vbCrLf & vbCrLf & _
"The first 2 cells in this range are blank."
Call MsgBox(sMessage, vbOKOnly + vbInformation, "Two Blank Cells")
Call Tracer_Add("MESSAGE", sMessage)
End Sub
Message_NoDataRangeIsSelected
Public Sub Message_NoDataRangeIsSelected()
Dim sMessage As String
sMessage = "You must select your cells first." & _
vbCrLf & vbCrLf & _
"The active window might have changed."
Call MsgBox(sMessage, vbOKOnly + vbInformation, "No Range Selected")
Call Tracer_Add("MESSAGE", sMessage)
End Sub
Range_ContainsRange
Public Function Range_ContainsRange(rng1, rng2) As Boolean
' Returns True if rng1 is a subset of rng2
InRange = False
If rng1.Parent.Parent.Name = rng2.Parent.Parent.Name Then
If rng1.Parent.Name = rng2.Parent.Name Then
If Union(rng1, rng2).Address = rng2.Address Then
InRange = True
End If
End If
End If
End Function
Ranges_SameColumns
Public Function Ranges_SameColumns(ByVal objRange1 As Range, _
ByVal objRange2 As Range) _
As Boolean
Dim bsamecolumns As Boolean
On Error GoTo AnError
bsamecolumns = False
If (objRange1.Column = objRange2.Column) Then
If (objRange1.Columns.Count = objRange2.Columns.Count) Then
bsamecolumns = True
End If
End If
Ranges_SameColumns = bsamecolumns
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "Ranges_SameColumns", Err)
End Function
Ranges_SameRows
Public Function Ranges_SameRows(ByVal objRange1 As Range, _
ByVal objRange2 As Range) _
As Boolean
Dim bsamerows As Boolean
On Error GoTo AnError
bsamerows = False
If (objRange1.Row = objRange2.Row) Then
If (objRange1.Rows.Count = objRange2.Rows.Count) Then
bsamerows = True
End If
End If
Ranges_SameRows = bsamerows
Exit Function
AnError:
Call Error_Handle(msMODULENAME, "Ranges_SameRows", Err)
End Function
© 2025 Better Solutions Limited. All Rights Reserved. © 2025 Better Solutions Limited Top