T
Tim Childs
Hi
I enclose some code that forms one code module within a file utility that I
use to automate the formatting of data downloaded from a financial system. I
think other people might find it useful, although they may want to edit it.
It is almost certainly a bit amateur in places, but it works for me and a
number of my colleagues, too. It is also designed to work in a browser
(http) Excel window, which makes the coding more complicated: not all Excel
functionality is available in a browser window.
It forms part of a larger file that includes a header extraction facility
(of columns that are full of the same data) and also a facility for deleting
rows where one (or two, if need be) have zeroes in specified column(s).
(Thanks to Bob Phillips for the latter). Please email me for file if
interested.
I did check with one of the senior* posters, who thought such a long post
was not any terrible hassle - sorry if it is. I haven't managed to cut all
the lines down to 80 characters - pl email if a problem.
Regards
Tim
*by experience, not age!
*************************************************************
Option Explicit
Option Compare Text
Option Base 1
Public bMultiSheetTestMode As Boolean
'Const bTimerOn = False
Dim bHTTPwindow As Boolean
Dim dColHeaderWidth() As Double
Dim iCol As Integer
Dim iFinalCol As Integer
Dim iFirstDataRow As Integer
Dim iHeaderRow As Integer
Dim iZoomFactor As Integer
Dim lFinalRow As Long
Dim lRow As Long
Dim sErrorMsg
Dim StartFrmtMilli
Sub FormatData_MASTER()
If TypeName(Selection) <> "Range" Then 'Nothing, if no Selection
MsgBox "Macro Quitting as no workbook active"
Exit Sub
End If
Call FormatData_VISIBLE
'condition added to stop any formatting changes
'where there is no HeaderRow found
If iHeaderRow > 0 Then Call FormatData_NOT_VISIBLE
End Sub
Sub FormatData_VISIBLE(Optional vDummy As Integer) 'Dummy to make
"invisible" or not
Dim bCalledByMenu As Boolean
Dim Ctrl As Office.CommandBarControl
Dim dMaxColWidth() As Double
Dim dNewColWidth
Dim iDataCols 'not necessarily final col in UsedRange
Dim iMaxColChars
Dim iTemp As Integer
Dim rTempRange As Range
Dim oFormulaFound As Object 'new 23 Jan 03
Dim rDataRange As Range
Dim iMaxArraySize As Integer
Dim rHeaderRange As Range
Dim sCurrencyFormat As String
Dim sDataType() As String
Dim sDateFormat As String
Dim sDateTimeFormat As String
Dim sIntegerFormat As String
Dim sTimeOnlyFormat As String
Dim Temp As Variant
Dim rng
Dim cell
Dim vDataArray As Variant 'This ARRAY contains the HeaderRow at Line 1 and
up to 499 rows of data
'The data is either the whole of the data area if less than 499 lines,
or,
' the first 249 lines and the last 250 lines, making 500 in total
including the header.
iZoomFactor = Application.ActiveWindow.Zoom
iHeaderRow = 0 'initialisation needed: variable is module-declared -
therefore
'holds value in between proc. runs
On Error Resume Next
Set Ctrl = Application.CommandBars.ActionControl 'check source of this code
on ng.. - TPC 13 Nov 04
If Ctrl Is Nothing Then
'Debug.Print "Not called from a control"
Else
'Debug.Print "Called from: " & Ctrl.Caption
bCalledByMenu = True
End If
If Left(ActiveWorkbook.Path, 4) = "http" Then bHTTPwindow = True
If bHTTPwindow = True And bCalledByMenu = True Then
Application.ScreenUpdating = True 'need screen updating ON when using a
http browser window
Else
Application.ScreenUpdating = False
End If
Application.StatusBar = "Processing Format for Workbook"
With ActiveWorkbook.ActiveSheet
iFinalCol = .UsedRange.Columns.Count
lFinalRow = .UsedRange.Rows.Count
iDataCols = .Cells(lFinalRow, 1).CurrentRegion.Columns.Count
'deals with top row being justified across more columns than are
'filled with data - produces problems when finding iHeaderRow - TPC 13
Nov 04
If iFinalCol > iDataCols Then
If WorksheetFunction.CountA(ActiveSheet.Range("$1:$1")) = 1 Then
Range(.Cells(1, 1), .Cells(1, iFinalCol)).MergeCells = False
With Range(.Cells(1, 1), .Cells(1, iDataCols))
.HorizontalAlignment = xlCenterAcrossSelection
.MergeCells = True
End With
Else
Debug.Print "more than one cell with data - no merging is
appropriate"
End If
'Remove cformatting on unused columns on RHS
Range(.Cells(1, iDataCols + 1), .Cells(1, iFinalCol)).ClearFormats
.UsedRange
iFinalCol = .UsedRange.Columns.Count
End If
'determine where the headerrow is located
iHeaderRow = HeaderRowNo(ActiveWorkbook.ActiveSheet)
iFirstDataRow = iHeaderRow + 1
If iHeaderRow = 0 Then
'sErrorMsg given a value in HeaderRow function
If Len(sErrorMsg) > 0 Then MsgBox sErrorMsg 'where is ErrorMsg
initiated
Debug.Print "The variable iHeaderRow could not be set - macro
quitting"
Application.StatusBar = False
Exit Sub
End If
'test for formulae...
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow + 1, iCol).HasFormula And oFormulaFound Is
Nothing Then
Set oFormulaFound = .Cells(iHeaderRow + 1, iCol)
End If
Next iCol
'following code changes font in PeopleSoft Queries from font Arial
Unicode MS (not a TrueType font) to Arial
If iHeaderRow > 0 Then
If Range(.Cells(iHeaderRow, 1), .Cells(lFinalRow,
iFinalCol)).Font.Name = "Arial Unicode MS" Then
Range(.Cells(iHeaderRow, 1), .Cells(lFinalRow,
iFinalCol)).Font.Name = "Arial"
End If
End If
'Test for odd date time format output from PeopleSoft
'Added 11 Dec 03
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow + 1, iCol).Value Like "####-##-##-##.##" Then
Set rng = .Columns(iCol).SpecialCells( _
xlCellTypeConstants, xlTextValues)
If Not rng Is Nothing Then
For Each cell In rng
With cell
If cell Like "####-##-##-##.##" Then
cell.Value = DateSerial(Left(cell, 4), Mid(cell,
6, 2), _
Mid(cell, 9, 2)) + TimeSerial(Mid(cell, 12,
2), Mid(cell, 15, 2), 0)
End If
End With
Next cell
End If
End If
Next iCol
iMaxArraySize = 200 'next section reduces the number of rows where
'there are a large number of columns of data
If iFinalCol > 10 Then
iMaxArraySize = Int(500 / iFinalCol)
iMaxArraySize = Int(iMaxArraySize / 2) * 2 'to get an even number
iMaxArraySize = WorksheetFunction.Max(20, iMaxArraySize) 'MINIMUM of
20 rows required
End If
'Debug.Print "iMaxArraySize = " & iMaxArraySize
'Loading the DataArray **********
If lFinalRow - iHeaderRow + 1 <= iMaxArraySize Then 'small data set
vDataArray = Range(.Cells(iHeaderRow, 1), .Cells(lFinalRow,
iFinalCol))
Else 'large data set - reduced to defined max array size
ReDim vDataArray(iMaxArraySize, iFinalCol)
For lRow = 1 To iMaxArraySize / 2
For iCol = 1 To iFinalCol
vDataArray(lRow, iCol) = .Cells(lRow + iHeaderRow - 1, iCol)
'new 9 Aug 02
vDataArray(iMaxArraySize / 2 + lRow, iCol) =
..Cells(lFinalRow - iMaxArraySize / 2 + lRow, iCol)
Next iCol
Next lRow
End If
'could call print array here
' Call PrintArray(vDataArray, "vDataArray")
' Stop
'new lines - 31 dec 03: deals with problem of single line of data
'where the format finding "-end-of-loop" goes wrong
'Am not sure reasoning is correct here: it may go
'wrong for any Exit Loop on last line of Array
'try incrementing row at end of loop...TPC 11 Nov 04
ReDim sDataType(iFinalCol)
'The following code works on the data array (unless noted otherwise)
'a maximum of 500 lines incl Header
'Identify BLANK Columns
For iCol = 1 To iFinalCol
'Debug.Print "Number of Cells in col = " & iCol & " "_
' & WorksheetFunction.CountA(Range(Cells(2, iCol),
Cells(lFinalRow, iCol)))
If WorksheetFunction.CountA(Range(.Cells(iFirstDataRow, iCol),
..Cells(lFinalRow, iCol))) = 0 Then
sDataType(iCol) = "Blank"
End If
Next iCol
'New 31 October 03 - short test for Text in cells
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
If WorksheetFunction.IsNonText(Cells(iHeaderRow + 1, iCol)) =
False Then
sDataType(iCol) = "Text"
'if first cell value in column is text, then all must be
text (reasonable assumption)
End If
End If
Next iCol
'TEST FOR DATES - denoted by "Date"
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
If IsDate(vDataArray(lRow, iCol)) = False Then
If Len(vDataArray(lRow, iCol)) > 0 Then
Exit Do
End If
End If
lRow = lRow + 1
Loop
If lRow = UBound(vDataArray, 1) + 1 Then
sDataType(iCol) = "Date"
'Debug.Print "Date recognised in Col " & iCol
End If
If sDataType(iCol) = "Date" Then
Temp = 0 'new 23 Jan 03
For lRow = 2 To UBound(vDataArray, 1)
'Debug.Print "hour", Hour(vDataArray(lRow, iCol))
Temp = Temp + Hour(vDataArray(lRow, iCol)) +
Minute(vDataArray(lRow, iCol))
Next lRow
'Debug.Print "temp", Temp
If Temp > 0 Then 'used to be greater than 1, but replaced
with "> 0" TPC: 21 October 2003
'If Temp >= 1 Then
sDataType(iCol) = "DT"
End If
End If
End If
Next iCol
'there is a comment around 25 Jan o3 on ng about sorting out time-only
formats
'New Code to test for single small values in exchange rate area etc e.g.
GBP/USD rate amongst GBP/GBP integer values
'Added 4 October 2004 - to deal with Journal 114264 output
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
Temp = WorksheetFunction.Sum(Range(.Cells(iFirstDataRow, iCol),
..Cells(lFinalRow, iCol)))
If Abs(Temp - Round(Temp, 3)) > 0.000001 Then
sDataType(iCol) = "Curr_4"
End If
End If
Next iCol
'Test For INTEGERS
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
If WorksheetFunction.IsNumber(vDataArray(lRow, iCol)) =
False Then
If Len(vDataArray(lRow, iCol)) > 0 Then 'new 16 Oct 03
Exit Do
End If
End If
If Abs(vDataArray(lRow, iCol) - Int(vDataArray(lRow, iCol)))
End If
If Abs(vDataArray(lRow, iCol)) > 0 And Abs(vDataArray(lRow,
iCol)) < 1 Then
'found a small number between zero and 1 - traps single
v. small exchange rate..
Exit Do
End If
lRow = lRow + 1
Loop 'Until lRow = UBound(vDataArray, 1)
If lRow = UBound(vDataArray, 1) + 1 Then
sDataType(iCol) = "Integer"
'Debug.Print "Integer recognised in Col " & iCol
End If
End If
Next iCol
'Test For CURRENCY
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
lRow = lRow + 1
If WorksheetFunction.IsNumber(vDataArray(lRow, iCol)) =
False Then
If Len(vDataArray(lRow, iCol)) > 0 Then 'new 16 Oct 03
Temp = "not a currency number"
Exit Do
End If
End If
Loop
'Loop Until lRow = UBound(vDataArray, 1)
If lRow = UBound(vDataArray, 1) + 1 Then
sDataType(iCol) = "Curr_2"
' Debug.Print "Currency recognised in Col " & iCol
End If
End If
Next iCol
'Test For FOUR DECIMAL PLACES
'This is only needed because Peoplesoft used to output data to 3 d.p. -
prob could be removed in 2005
'dependent on how many Queries on historic data are run - TPC, 5 Aug
2004
For iCol = 1 To iFinalCol
If sDataType(iCol) = "Curr_2" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
If Len(vDataArray(lRow, iCol)) - InStr(1, vDataArray(lRow,
iCol), ".") > 3 _
And InStr(1, vDataArray(lRow, iCol), ".") <> 0 Then
sDataType(iCol) = "Curr_4"
Exit Do
End If
lRow = lRow + 1
Loop
End If
Next iCol
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
sDataType(iCol) = "Null"
End If
Next iCol
' **** For outputting the chosen format for each column ****
'' For iCol = 1 To iFinalCol
'' 'Debug.Print "Column " & iCol & " is " & sDataType(iCol)
'' Cells(lFinalRow + 2, iCol) = sDataType(iCol)
'' Next iCol
' Retrieving Chosen Formatting
If WksExists("Format_Choice") = True Then
sCurrencyFormat = sFindFormat("Currency")
sIntegerFormat = sFindFormat("Integer")
sDateFormat = sFindFormat("Date")
sDateTimeFormat = sFindFormat("DateTime")
'sTimeOnlyFormat = sFindFormat("TimeOnly")
Else
Debug.Print "Cannot find worksheet <Format_Choice> in Formatting
Utility workbook"
sCurrencyFormat = "#,##0.00_);[Red]-#,##0.00_)"
sIntegerFormat = "0_);-0_);0_);"
sDateFormat = "d-mmm-yy_)"
sDateTimeFormat = "d-mmm-yy hh:mm AM/PM"
End If
'' If sCurrencyFormat = "" Or sDateFormat = "" _
'' Or sIntegerFormat = "" Then
'' Debug.Print "Quitting AutoFormat Sub here"
'' Exit Sub
'' End If
For iCol = 1 To iFinalCol
Select Case sDataType(iCol)
Case "Curr_2"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sCurrencyFormat ' "#,##0.00;[Red]-#,##0.00"
Case "Integer"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sIntegerFormat ' "0"
Case "Date"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sDateFormat ' "dd-mmm-yy"
Case "DT"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sDateTimeFormat ' "dd-mmm-yy"
Case "Curr_4"
'added 14 Jan to deal with small exchange rates e.g.
0.0000345
'may need to revise this as it will "mess up" data that has
4 d.p and is NOT
'less than 0.0001 etc
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = "General"
Case Else
'Do nothing - want General format (exchange rates etc)
End Select
Next iCol
'This Section determines COLUMN WIDTHS
ReDim dMaxColWidth(iFinalCol)
For iCol = 1 To iFinalCol
Set rTempRange = Range(.Cells(iHeaderRow + 1, iCol),
Cells(lFinalRow, iCol))
With rTempRange
rTempRange.Columns.AutoFit
If WorksheetFunction.CountA(rTempRange) = 0 Then
'Column header in this column is blank
rTempRange.ColumnWidth = 1
End If
'Ensure column is wide enough for header
If dMaxColWidth(iCol) < rTempRange.ColumnWidth Then
dMaxColWidth(iCol) = rTempRange.ColumnWidth
End If
End With
'Debug.Print "Col " & iCol & " width = " & dMaxColWidth(iCol)
Next iCol
'Used column B in case the column with line numbers was output
With .Cells(iHeaderRow, 2).EntireRow
.Font.Bold = True
.WrapText = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
'.WrapText = True
End With
Call HeadingColWidth
'Turn wrap text off for DATA area
Range(.Cells(iFirstDataRow, 1), .Cells(lFinalRow, iFinalCol)).WrapText =
False
For iCol = 1 To iFinalCol
'Set this column to fit data specifically
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Columns.AutoFit 'set column width to data width
dNewColWidth = .Cells(1, iCol).EntireColumn.ColumnWidth
dNewColWidth = WorksheetFunction.Max(dColHeaderWidth(iCol),
dNewColWidth) 'choose heading col width if wider
dNewColWidth = WorksheetFunction.Min(50, dNewColWidth) 'No column to
exceed 50 chars wide
.Cells(iHeaderRow, iCol).EntireColumn.ColumnWidth = dNewColWidth
iMaxColChars = 1 'refers to max length of cell contents in data in
column, initialising
'should be 0 - TPC 13 Nov 04??
'new 4 August 03, amended 6 August 2003
iMaxColChars = Application.Evaluate("max(len(" &
Cells(iFirstDataRow, iCol).Address & ":" _
& Cells(lFinalRow, iCol).Address & "))")
If iMaxColChars < 4 Then 'Justify text where 3 or less characters
Range(.Cells(iHeaderRow, iCol), .Cells(lFinalRow,
iCol)).HorizontalAlignment = xlCenter
End If
Next iCol
'Setting Account to numeric as opposed to Labels
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow, iCol).Value = "Account" Then
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Value = _
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Value
End If
Next iCol
Rows(iHeaderRow).AutoFit 'set the RowHeight for Headings Row
Application.StatusBar = False
If bMultiSheetTestMode = False Then ' added 3 Sep 2003
'Don't want message on evry sheet when testing multiple sheets
simultaneously
If Not oFormulaFound Is Nothing Then
Application.ScreenUpdating = True
oFormulaFound.Select
If bHTTPwindow = False Then
MsgBox "formula found at Cell " & oFormulaFound.Address _
& "- this may reduce the " & vbCr & "effectiveness of
autoformatting.."
End If
Application.ScreenUpdating = False
End If
End If
End With
'TEMPORARILY COMMENTED OUT DURING DEVELOPMENT - 4 OCTOBER 2004 - refers to
OPAL Queries
'iTemp = Application.Evaluate("max(len(" & Cells(iFirstDataRow, 1).Address &
":" & Cells(lFinalRow, iCol).Address & "))")
'If iTemp > 100 Then
' Call RowHeightOptimise
'End If
End Sub
Sub RowHeightOptimise()
With Range(Cells(iFirstDataRow, 1), Cells(lFinalRow, iFinalCol))
.WrapText = True
.Rows.AutoFit
.VerticalAlignment = xlCenter
End With
For lRow = iFirstDataRow To lFinalRow
If Cells(lRow, 1).RowHeight > 100 Then Cells(lRow, 1).RowHeight = 100
Next lRow
'''Determining if Fonts are all equal
''Print Selection.Font.Size
''Null
''10
''Application.Evaluate ("counta(len(A1:A3))")
''Can also use sum and therefore get a true figure: average
''includes blank cells in denominator
End Sub
Private Sub HeadingColWidth()
Dim lColNo As Integer
Dim lRowNo As Integer
Dim iSpacePos As Integer
Dim sNewWkBk As String
Dim sOrigWkBk As String
Dim oNewSheet As Object
Dim oOrigSheet As Object
lColNo = 1
lRowNo = 1
sOrigWkBk = ActiveWorkbook.Name
Set oOrigSheet = ActiveWorkbook.ActiveSheet
If bHTTPwindow = True Then 'Cannot add workbooks to a http window
Set oNewSheet = ActiveWorkbook.Sheets.Add
Else
Workbooks.Add (1)
Set oNewSheet = ActiveWorkbook.ActiveSheet
End If
sNewWkBk = ActiveWorkbook.Name
With oNewSheet
Application.ActiveWindow.Zoom = iZoomFactor
oOrigSheet.Rows(iHeaderRow).Copy Destination:=.Range("A1")
.Range("A1:IV1").Copy
.Range("A2:IV10").PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
.Range("A1:IV10").WrapText = False
'allocating the contents of the header word-by word to cells below
Do Until .Cells(lRowNo, lColNo) = "" And .Cells(lRowNo, lColNo + 1) = ""
' in case the first cell is empty
Do Until InStr(1, .Cells(lRowNo, lColNo), " ") = 0
iSpacePos = InStr(1, .Cells(lRowNo, lColNo), " ")
.Cells(lRowNo + 1, lColNo) = Right(.Cells(lRowNo, lColNo),
Len(.Cells(lRowNo, lColNo)) - iSpacePos)
.Cells(lRowNo, lColNo) = Left(.Cells(lRowNo, lColNo),
iSpacePos - 1) 'need to following row before current one..
lRowNo = lRowNo + 1
Loop
lColNo = lColNo + 1
lRowNo = 1
Loop
.Range("A1:IV1").EntireColumn.AutoFit 'Should use Used Range here?
'Dim i As Integer 'Used to check actual columnwidth in debugging
'For i = 1 To 30
' Cells(12, i) = "W= " & Format(Cells(12, i).ColumnWidth, "0.0")
'Next i
'Load up the column widths into the array
ReDim dColHeaderWidth(iFinalCol)
For lColNo = 1 To iFinalCol
dColHeaderWidth(lColNo) = .Cells(1, lColNo).ColumnWidth
Next lColNo
End With
If bHTTPwindow = True Then
oNewSheet.Visible = False
Else
Workbooks(sNewWkBk).Close savechanges:=False
End If
End Sub
Function sFindFormat(sFormatType)
Dim vMatch
Dim msg
Dim vResult
vMatch = Application.Match(sFormatType,
ThisWorkbook.Worksheets("Format_Choice").Range("A:A"), 0)
If IsError(vMatch) = True Then
msg = "The value " & Chr(34) & sFormatType & Chr(34) & " is not
found in the data lookup table " _
& vbCr & "Do you want to use a default value (else macro will
stop)?"
' MsgBoxTitle = " WARNING on Combined Project Code " & Chr(34) &
CombinationCode & Chr(34)
vResult = MsgBox(msg, vbYesNo + vbCritical, "Cannot find value")
If vResult = vbYes Then
Select Case sFormatType
Case "Integer"
sFindFormat = "0_);-0_);0_);"
Case "Currency"
sFindFormat = "#,##0.00_);[Red]-#,##0.00_)"
Case "Date"
sFindFormat = "d-mmm-yy_)"
Case "DT"
sFindFormat = "d-mmm-yy hh:mm AM/PM_)"
End Select
End If
Exit Function
End If
sFindFormat = ThisWorkbook.Worksheets("Format_Choice").Cells(vMatch,
2).NumberFormat
End Function
Sub FormatData_NOT_VISIBLE(Optional vDummy As Integer) 'Dummy to make
"invisible")
Dim bPrintGridLines As Boolean
With ActiveWorkbook.ActiveSheet
If .PageSetup.PrintTitleRows = "" And iHeaderRow > 0 Then 'iHeaderRow >
0 added 20 Dec 02
If .UsedRange.Rows.Count > 35 Then 'not worth setting if a small
spreadsheet
.PageSetup.PrintTitleRows = "$" & iHeaderRow & ":" & "$" &
iHeaderRow 'amended 26 July 02
End If
End If
If WksExists("Format_Choice") = True Then
bPrintGridLines = WorksheetFunction.VLookup("Gridlines",
ThisWorkbook.Sheets("Format_Choice").Range("A:B"), 2, 0)
Else
bPrintGridLines = True
End If
If bPrintGridLines = True Then
' If bTimerOn Then
' Dim StartTime1
' StartTime1 = Now
' End If
If iHeaderRow > 0 Then
With .Cells(iHeaderRow, 1).CurrentRegion
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End If
'do not comment out
'the "if" statement is to avoid setting the PrintGridlines
needlessly
With .PageSetup
If .PrintGridlines = False Then
.PrintGridlines = True
End If
End With
End If
'Section to Replace Project Activity codes "03" output as "3" - no
longer required -will be in CSV files?
If iHeaderRow > 0 Then 'this is not needed as the proc. is not called
if iheaderrow = 0 'TPC 17 July 2003
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow, iCol) = "Activity" And iCol > 2 Then
'iCol >2 to prevent error on col 1 etc and minimise chance
of formatting "wrong" column
If Left(Cells(iHeaderRow, iCol - 1), 4) = "Proj" Then
'this must come first
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="00", _
Replacement:="'00", LookAt:=xlWhole,
SearchOrder:=xlByRows, MatchCase:=False
'this stops the problem of a second quote (ASCII 39)
being placed at the beginning of the "00"
'solution supplied by Tom Ogilvy on 18 July 03 - note
this: LookAt:=xlPart, as opposed to xlWhole
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace _
What:="'00", Replacement:="00", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="0", _
Replacement:="'00", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="3", Replacement:="'03", _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="8", Replacement:="'08", _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
End If
'Ensuring the defaults on find are set to part-word, and not
match-case
'may not be required here anymore as repeated below - tpc 28
June 03
End If
Next iCol
End If
On Error Resume Next
.Cells.Replace What:="£", Replacement:=" £", LookAt:=xlPart,
SearchOrder _
:=xlByRows, MatchCase:=False
On Error GoTo 0
'tpc 28 June 03
'Ensuring the defaults on find are set to part-word, and not match-case
Range("AA1000:AA1002").Replace What:="", Replacement:="",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End With
End Sub
Private Function HeaderRowNo(oSheet As Object) 'Need to pass object in case
of HTTP windows...
Dim lRow
Dim iLastDataCol As Integer
Dim lFinalRow
Dim iStoreRowNo As Integer
Dim rHeaderCurrRegion As Range
Dim lHeaderCurrRegionLastRow As Long
Dim iHeaderCurrRegionLastCol As Integer
sErrorMsg = ""
'use this in generalised function for last row
iLastDataCol = oSheet.Cells.Find("*", [A1], , , xlByColumns,
xlPrevious).Column
lFinalRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
With oSheet
lRow = 1
Do Until lRow > WorksheetFunction.Max(40, lFinalRow)
'first test is for all cells in a given row to be non-blank
'second tests that all but one cell are non-blank (for outputs of 4
or more columns)
If WorksheetFunction.CountA(.Rows(lRow)) = iLastDataCol Or _
WorksheetFunction.CountA(.Range(.Cells(lRow, 2),
..Cells(lRow, iLastDataCol))) = iLastDataCol - 1 Then
'
' (iLastDataCol > 3 And _
' WorksheetFunction.CountA(.Rows(lRow)) = iLastDataCol - 1)
Then
iStoreRowNo = lRow
Exit Do
End If
lRow = lRow + 1
Loop
'Test here for Current Region extending to last right hand cell
If iStoreRowNo > 0 Then
Set rHeaderCurrRegion = .Cells(iStoreRowNo, 2).CurrentRegion
lHeaderCurrRegionLastRow = rHeaderCurrRegion.Row +
rHeaderCurrRegion.Rows.Count - 1
iHeaderCurrRegionLastCol = rHeaderCurrRegion.Column +
rHeaderCurrRegion.Columns.Count - 1
If lHeaderCurrRegionLastRow < lFinalRow Then
sErrorMsg = "Theoretical header row is " & iStoreRowNo & ". The
last row of the <current region> of header is Row " _
& lHeaderCurrRegionLastRow & " and is less"
sErrorMsg = sErrorMsg & vbCr & "than the very last row of the
worksheet itself, which is Row " & lFinalRow _
& " - therefore cannot validly set the header." & vbCr &
vbCr
iStoreRowNo = 0
ElseIf iHeaderCurrRegionLastCol < iLastDataCol Then
sErrorMsg = "Theoretical header row is " & iStoreRowNo & ". The
last column of the <current region> of header is Column " _
& ColConv(iHeaderCurrRegionLastCol) & " and is less"
sErrorMsg = sErrorMsg & vbCr & "than the very last column of the
worksheet itself," _
& " which is Column " & ColConv(iLastDataCol) & " -
therefore cannot validly set the header." & vbCr & vbCr
'sErrorMsg = "Last col of the <current region> header less than
main spreadsheet itself- cannot set header"
iStoreRowNo = 0
End If
End If
End With
If iStoreRowNo = 0 Then
sErrorMsg = sErrorMsg & "Macro could not properly determine the header
row for data." & vbCr
sErrorMsg = sErrorMsg & "This may be because data was added to the RHS
or bottom after its creation." & vbCr
sErrorMsg = sErrorMsg & "NOTE: it is best to run this macro at the
earliest opportunity after obtaining data." & vbCr
Debug.Print "The HeaderRow could not be set - macro quitting."
End If
HeaderRowNo = iStoreRowNo
End Function
Private Function ColConv(ColNo As Integer)
'No need to declare as public if in same module
If ColNo > 0 And ColNo < 27 Then
ColConv = Chr(65 + (ColNo - 1) Mod 26)
ElseIf ColNo > 26 And ColNo < 257 Then
ColConv = Chr(65 + Int(ColNo / 26) - 1) & Chr(65 + (ColNo - 1) Mod 26)
Else
ColConv = "{Error Value - supply valid column number}"
End If
End Function
Function WksExists(wksName As String) As Boolean
On Error Resume Next
'Note incusion of ThisWorkbook qualifier below
WksExists = CBool(Len(ThisWorkbook.Worksheets(wksName).Name) > 0)
End Function
I enclose some code that forms one code module within a file utility that I
use to automate the formatting of data downloaded from a financial system. I
think other people might find it useful, although they may want to edit it.
It is almost certainly a bit amateur in places, but it works for me and a
number of my colleagues, too. It is also designed to work in a browser
(http) Excel window, which makes the coding more complicated: not all Excel
functionality is available in a browser window.
It forms part of a larger file that includes a header extraction facility
(of columns that are full of the same data) and also a facility for deleting
rows where one (or two, if need be) have zeroes in specified column(s).
(Thanks to Bob Phillips for the latter). Please email me for file if
interested.
I did check with one of the senior* posters, who thought such a long post
was not any terrible hassle - sorry if it is. I haven't managed to cut all
the lines down to 80 characters - pl email if a problem.
Regards
Tim
*by experience, not age!
*************************************************************
Option Explicit
Option Compare Text
Option Base 1
Public bMultiSheetTestMode As Boolean
'Const bTimerOn = False
Dim bHTTPwindow As Boolean
Dim dColHeaderWidth() As Double
Dim iCol As Integer
Dim iFinalCol As Integer
Dim iFirstDataRow As Integer
Dim iHeaderRow As Integer
Dim iZoomFactor As Integer
Dim lFinalRow As Long
Dim lRow As Long
Dim sErrorMsg
Dim StartFrmtMilli
Sub FormatData_MASTER()
If TypeName(Selection) <> "Range" Then 'Nothing, if no Selection
MsgBox "Macro Quitting as no workbook active"
Exit Sub
End If
Call FormatData_VISIBLE
'condition added to stop any formatting changes
'where there is no HeaderRow found
If iHeaderRow > 0 Then Call FormatData_NOT_VISIBLE
End Sub
Sub FormatData_VISIBLE(Optional vDummy As Integer) 'Dummy to make
"invisible" or not
Dim bCalledByMenu As Boolean
Dim Ctrl As Office.CommandBarControl
Dim dMaxColWidth() As Double
Dim dNewColWidth
Dim iDataCols 'not necessarily final col in UsedRange
Dim iMaxColChars
Dim iTemp As Integer
Dim rTempRange As Range
Dim oFormulaFound As Object 'new 23 Jan 03
Dim rDataRange As Range
Dim iMaxArraySize As Integer
Dim rHeaderRange As Range
Dim sCurrencyFormat As String
Dim sDataType() As String
Dim sDateFormat As String
Dim sDateTimeFormat As String
Dim sIntegerFormat As String
Dim sTimeOnlyFormat As String
Dim Temp As Variant
Dim rng
Dim cell
Dim vDataArray As Variant 'This ARRAY contains the HeaderRow at Line 1 and
up to 499 rows of data
'The data is either the whole of the data area if less than 499 lines,
or,
' the first 249 lines and the last 250 lines, making 500 in total
including the header.
iZoomFactor = Application.ActiveWindow.Zoom
iHeaderRow = 0 'initialisation needed: variable is module-declared -
therefore
'holds value in between proc. runs
On Error Resume Next
Set Ctrl = Application.CommandBars.ActionControl 'check source of this code
on ng.. - TPC 13 Nov 04
If Ctrl Is Nothing Then
'Debug.Print "Not called from a control"
Else
'Debug.Print "Called from: " & Ctrl.Caption
bCalledByMenu = True
End If
If Left(ActiveWorkbook.Path, 4) = "http" Then bHTTPwindow = True
If bHTTPwindow = True And bCalledByMenu = True Then
Application.ScreenUpdating = True 'need screen updating ON when using a
http browser window
Else
Application.ScreenUpdating = False
End If
Application.StatusBar = "Processing Format for Workbook"
With ActiveWorkbook.ActiveSheet
iFinalCol = .UsedRange.Columns.Count
lFinalRow = .UsedRange.Rows.Count
iDataCols = .Cells(lFinalRow, 1).CurrentRegion.Columns.Count
'deals with top row being justified across more columns than are
'filled with data - produces problems when finding iHeaderRow - TPC 13
Nov 04
If iFinalCol > iDataCols Then
If WorksheetFunction.CountA(ActiveSheet.Range("$1:$1")) = 1 Then
Range(.Cells(1, 1), .Cells(1, iFinalCol)).MergeCells = False
With Range(.Cells(1, 1), .Cells(1, iDataCols))
.HorizontalAlignment = xlCenterAcrossSelection
.MergeCells = True
End With
Else
Debug.Print "more than one cell with data - no merging is
appropriate"
End If
'Remove cformatting on unused columns on RHS
Range(.Cells(1, iDataCols + 1), .Cells(1, iFinalCol)).ClearFormats
.UsedRange
iFinalCol = .UsedRange.Columns.Count
End If
'determine where the headerrow is located
iHeaderRow = HeaderRowNo(ActiveWorkbook.ActiveSheet)
iFirstDataRow = iHeaderRow + 1
If iHeaderRow = 0 Then
'sErrorMsg given a value in HeaderRow function
If Len(sErrorMsg) > 0 Then MsgBox sErrorMsg 'where is ErrorMsg
initiated
Debug.Print "The variable iHeaderRow could not be set - macro
quitting"
Application.StatusBar = False
Exit Sub
End If
'test for formulae...
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow + 1, iCol).HasFormula And oFormulaFound Is
Nothing Then
Set oFormulaFound = .Cells(iHeaderRow + 1, iCol)
End If
Next iCol
'following code changes font in PeopleSoft Queries from font Arial
Unicode MS (not a TrueType font) to Arial
If iHeaderRow > 0 Then
If Range(.Cells(iHeaderRow, 1), .Cells(lFinalRow,
iFinalCol)).Font.Name = "Arial Unicode MS" Then
Range(.Cells(iHeaderRow, 1), .Cells(lFinalRow,
iFinalCol)).Font.Name = "Arial"
End If
End If
'Test for odd date time format output from PeopleSoft
'Added 11 Dec 03
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow + 1, iCol).Value Like "####-##-##-##.##" Then
Set rng = .Columns(iCol).SpecialCells( _
xlCellTypeConstants, xlTextValues)
If Not rng Is Nothing Then
For Each cell In rng
With cell
If cell Like "####-##-##-##.##" Then
cell.Value = DateSerial(Left(cell, 4), Mid(cell,
6, 2), _
Mid(cell, 9, 2)) + TimeSerial(Mid(cell, 12,
2), Mid(cell, 15, 2), 0)
End If
End With
Next cell
End If
End If
Next iCol
iMaxArraySize = 200 'next section reduces the number of rows where
'there are a large number of columns of data
If iFinalCol > 10 Then
iMaxArraySize = Int(500 / iFinalCol)
iMaxArraySize = Int(iMaxArraySize / 2) * 2 'to get an even number
iMaxArraySize = WorksheetFunction.Max(20, iMaxArraySize) 'MINIMUM of
20 rows required
End If
'Debug.Print "iMaxArraySize = " & iMaxArraySize
'Loading the DataArray **********
If lFinalRow - iHeaderRow + 1 <= iMaxArraySize Then 'small data set
vDataArray = Range(.Cells(iHeaderRow, 1), .Cells(lFinalRow,
iFinalCol))
Else 'large data set - reduced to defined max array size
ReDim vDataArray(iMaxArraySize, iFinalCol)
For lRow = 1 To iMaxArraySize / 2
For iCol = 1 To iFinalCol
vDataArray(lRow, iCol) = .Cells(lRow + iHeaderRow - 1, iCol)
'new 9 Aug 02
vDataArray(iMaxArraySize / 2 + lRow, iCol) =
..Cells(lFinalRow - iMaxArraySize / 2 + lRow, iCol)
Next iCol
Next lRow
End If
'could call print array here
' Call PrintArray(vDataArray, "vDataArray")
' Stop
'new lines - 31 dec 03: deals with problem of single line of data
'where the format finding "-end-of-loop" goes wrong
'Am not sure reasoning is correct here: it may go
'wrong for any Exit Loop on last line of Array
'try incrementing row at end of loop...TPC 11 Nov 04
ReDim sDataType(iFinalCol)
'The following code works on the data array (unless noted otherwise)
'a maximum of 500 lines incl Header
'Identify BLANK Columns
For iCol = 1 To iFinalCol
'Debug.Print "Number of Cells in col = " & iCol & " "_
' & WorksheetFunction.CountA(Range(Cells(2, iCol),
Cells(lFinalRow, iCol)))
If WorksheetFunction.CountA(Range(.Cells(iFirstDataRow, iCol),
..Cells(lFinalRow, iCol))) = 0 Then
sDataType(iCol) = "Blank"
End If
Next iCol
'New 31 October 03 - short test for Text in cells
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
If WorksheetFunction.IsNonText(Cells(iHeaderRow + 1, iCol)) =
False Then
sDataType(iCol) = "Text"
'if first cell value in column is text, then all must be
text (reasonable assumption)
End If
End If
Next iCol
'TEST FOR DATES - denoted by "Date"
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
If IsDate(vDataArray(lRow, iCol)) = False Then
If Len(vDataArray(lRow, iCol)) > 0 Then
Exit Do
End If
End If
lRow = lRow + 1
Loop
If lRow = UBound(vDataArray, 1) + 1 Then
sDataType(iCol) = "Date"
'Debug.Print "Date recognised in Col " & iCol
End If
If sDataType(iCol) = "Date" Then
Temp = 0 'new 23 Jan 03
For lRow = 2 To UBound(vDataArray, 1)
'Debug.Print "hour", Hour(vDataArray(lRow, iCol))
Temp = Temp + Hour(vDataArray(lRow, iCol)) +
Minute(vDataArray(lRow, iCol))
Next lRow
'Debug.Print "temp", Temp
If Temp > 0 Then 'used to be greater than 1, but replaced
with "> 0" TPC: 21 October 2003
'If Temp >= 1 Then
sDataType(iCol) = "DT"
End If
End If
End If
Next iCol
'there is a comment around 25 Jan o3 on ng about sorting out time-only
formats
'New Code to test for single small values in exchange rate area etc e.g.
GBP/USD rate amongst GBP/GBP integer values
'Added 4 October 2004 - to deal with Journal 114264 output
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
Temp = WorksheetFunction.Sum(Range(.Cells(iFirstDataRow, iCol),
..Cells(lFinalRow, iCol)))
If Abs(Temp - Round(Temp, 3)) > 0.000001 Then
sDataType(iCol) = "Curr_4"
End If
End If
Next iCol
'Test For INTEGERS
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
If WorksheetFunction.IsNumber(vDataArray(lRow, iCol)) =
False Then
If Len(vDataArray(lRow, iCol)) > 0 Then 'new 16 Oct 03
Exit Do
End If
End If
If Abs(vDataArray(lRow, iCol) - Int(vDataArray(lRow, iCol)))
Exit Do
End If
If Abs(vDataArray(lRow, iCol)) > 0 And Abs(vDataArray(lRow,
iCol)) < 1 Then
'found a small number between zero and 1 - traps single
v. small exchange rate..
Exit Do
End If
lRow = lRow + 1
Loop 'Until lRow = UBound(vDataArray, 1)
If lRow = UBound(vDataArray, 1) + 1 Then
sDataType(iCol) = "Integer"
'Debug.Print "Integer recognised in Col " & iCol
End If
End If
Next iCol
'Test For CURRENCY
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
lRow = lRow + 1
If WorksheetFunction.IsNumber(vDataArray(lRow, iCol)) =
False Then
If Len(vDataArray(lRow, iCol)) > 0 Then 'new 16 Oct 03
Temp = "not a currency number"
Exit Do
End If
End If
Loop
'Loop Until lRow = UBound(vDataArray, 1)
If lRow = UBound(vDataArray, 1) + 1 Then
sDataType(iCol) = "Curr_2"
' Debug.Print "Currency recognised in Col " & iCol
End If
End If
Next iCol
'Test For FOUR DECIMAL PLACES
'This is only needed because Peoplesoft used to output data to 3 d.p. -
prob could be removed in 2005
'dependent on how many Queries on historic data are run - TPC, 5 Aug
2004
For iCol = 1 To iFinalCol
If sDataType(iCol) = "Curr_2" Then
lRow = 2
Do While lRow <= UBound(vDataArray, 1)
If Len(vDataArray(lRow, iCol)) - InStr(1, vDataArray(lRow,
iCol), ".") > 3 _
And InStr(1, vDataArray(lRow, iCol), ".") <> 0 Then
sDataType(iCol) = "Curr_4"
Exit Do
End If
lRow = lRow + 1
Loop
End If
Next iCol
For iCol = 1 To iFinalCol
If sDataType(iCol) = "" Then
sDataType(iCol) = "Null"
End If
Next iCol
' **** For outputting the chosen format for each column ****
'' For iCol = 1 To iFinalCol
'' 'Debug.Print "Column " & iCol & " is " & sDataType(iCol)
'' Cells(lFinalRow + 2, iCol) = sDataType(iCol)
'' Next iCol
' Retrieving Chosen Formatting
If WksExists("Format_Choice") = True Then
sCurrencyFormat = sFindFormat("Currency")
sIntegerFormat = sFindFormat("Integer")
sDateFormat = sFindFormat("Date")
sDateTimeFormat = sFindFormat("DateTime")
'sTimeOnlyFormat = sFindFormat("TimeOnly")
Else
Debug.Print "Cannot find worksheet <Format_Choice> in Formatting
Utility workbook"
sCurrencyFormat = "#,##0.00_);[Red]-#,##0.00_)"
sIntegerFormat = "0_);-0_);0_);"
sDateFormat = "d-mmm-yy_)"
sDateTimeFormat = "d-mmm-yy hh:mm AM/PM"
End If
'' If sCurrencyFormat = "" Or sDateFormat = "" _
'' Or sIntegerFormat = "" Then
'' Debug.Print "Quitting AutoFormat Sub here"
'' Exit Sub
'' End If
For iCol = 1 To iFinalCol
Select Case sDataType(iCol)
Case "Curr_2"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sCurrencyFormat ' "#,##0.00;[Red]-#,##0.00"
Case "Integer"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sIntegerFormat ' "0"
Case "Date"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sDateFormat ' "dd-mmm-yy"
Case "DT"
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = sDateTimeFormat ' "dd-mmm-yy"
Case "Curr_4"
'added 14 Jan to deal with small exchange rates e.g.
0.0000345
'may need to revise this as it will "mess up" data that has
4 d.p and is NOT
'less than 0.0001 etc
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).NumberFormat = "General"
Case Else
'Do nothing - want General format (exchange rates etc)
End Select
Next iCol
'This Section determines COLUMN WIDTHS
ReDim dMaxColWidth(iFinalCol)
For iCol = 1 To iFinalCol
Set rTempRange = Range(.Cells(iHeaderRow + 1, iCol),
Cells(lFinalRow, iCol))
With rTempRange
rTempRange.Columns.AutoFit
If WorksheetFunction.CountA(rTempRange) = 0 Then
'Column header in this column is blank
rTempRange.ColumnWidth = 1
End If
'Ensure column is wide enough for header
If dMaxColWidth(iCol) < rTempRange.ColumnWidth Then
dMaxColWidth(iCol) = rTempRange.ColumnWidth
End If
End With
'Debug.Print "Col " & iCol & " width = " & dMaxColWidth(iCol)
Next iCol
'Used column B in case the column with line numbers was output
With .Cells(iHeaderRow, 2).EntireRow
.Font.Bold = True
.WrapText = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
'.WrapText = True
End With
Call HeadingColWidth
'Turn wrap text off for DATA area
Range(.Cells(iFirstDataRow, 1), .Cells(lFinalRow, iFinalCol)).WrapText =
False
For iCol = 1 To iFinalCol
'Set this column to fit data specifically
Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Columns.AutoFit 'set column width to data width
dNewColWidth = .Cells(1, iCol).EntireColumn.ColumnWidth
dNewColWidth = WorksheetFunction.Max(dColHeaderWidth(iCol),
dNewColWidth) 'choose heading col width if wider
dNewColWidth = WorksheetFunction.Min(50, dNewColWidth) 'No column to
exceed 50 chars wide
.Cells(iHeaderRow, iCol).EntireColumn.ColumnWidth = dNewColWidth
iMaxColChars = 1 'refers to max length of cell contents in data in
column, initialising
'should be 0 - TPC 13 Nov 04??
'new 4 August 03, amended 6 August 2003
iMaxColChars = Application.Evaluate("max(len(" &
Cells(iFirstDataRow, iCol).Address & ":" _
& Cells(lFinalRow, iCol).Address & "))")
If iMaxColChars < 4 Then 'Justify text where 3 or less characters
Range(.Cells(iHeaderRow, iCol), .Cells(lFinalRow,
iCol)).HorizontalAlignment = xlCenter
End If
Next iCol
'Setting Account to numeric as opposed to Labels
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow, iCol).Value = "Account" Then
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Value = _
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Value
End If
Next iCol
Rows(iHeaderRow).AutoFit 'set the RowHeight for Headings Row
Application.StatusBar = False
If bMultiSheetTestMode = False Then ' added 3 Sep 2003
'Don't want message on evry sheet when testing multiple sheets
simultaneously
If Not oFormulaFound Is Nothing Then
Application.ScreenUpdating = True
oFormulaFound.Select
If bHTTPwindow = False Then
MsgBox "formula found at Cell " & oFormulaFound.Address _
& "- this may reduce the " & vbCr & "effectiveness of
autoformatting.."
End If
Application.ScreenUpdating = False
End If
End If
End With
'TEMPORARILY COMMENTED OUT DURING DEVELOPMENT - 4 OCTOBER 2004 - refers to
OPAL Queries
'iTemp = Application.Evaluate("max(len(" & Cells(iFirstDataRow, 1).Address &
":" & Cells(lFinalRow, iCol).Address & "))")
'If iTemp > 100 Then
' Call RowHeightOptimise
'End If
End Sub
Sub RowHeightOptimise()
With Range(Cells(iFirstDataRow, 1), Cells(lFinalRow, iFinalCol))
.WrapText = True
.Rows.AutoFit
.VerticalAlignment = xlCenter
End With
For lRow = iFirstDataRow To lFinalRow
If Cells(lRow, 1).RowHeight > 100 Then Cells(lRow, 1).RowHeight = 100
Next lRow
'''Determining if Fonts are all equal
''Print Selection.Font.Size
''Null
''10
''Application.Evaluate ("counta(len(A1:A3))")
''Can also use sum and therefore get a true figure: average
''includes blank cells in denominator
End Sub
Private Sub HeadingColWidth()
Dim lColNo As Integer
Dim lRowNo As Integer
Dim iSpacePos As Integer
Dim sNewWkBk As String
Dim sOrigWkBk As String
Dim oNewSheet As Object
Dim oOrigSheet As Object
lColNo = 1
lRowNo = 1
sOrigWkBk = ActiveWorkbook.Name
Set oOrigSheet = ActiveWorkbook.ActiveSheet
If bHTTPwindow = True Then 'Cannot add workbooks to a http window
Set oNewSheet = ActiveWorkbook.Sheets.Add
Else
Workbooks.Add (1)
Set oNewSheet = ActiveWorkbook.ActiveSheet
End If
sNewWkBk = ActiveWorkbook.Name
With oNewSheet
Application.ActiveWindow.Zoom = iZoomFactor
oOrigSheet.Rows(iHeaderRow).Copy Destination:=.Range("A1")
.Range("A1:IV1").Copy
.Range("A2:IV10").PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
.Range("A1:IV10").WrapText = False
'allocating the contents of the header word-by word to cells below
Do Until .Cells(lRowNo, lColNo) = "" And .Cells(lRowNo, lColNo + 1) = ""
' in case the first cell is empty
Do Until InStr(1, .Cells(lRowNo, lColNo), " ") = 0
iSpacePos = InStr(1, .Cells(lRowNo, lColNo), " ")
.Cells(lRowNo + 1, lColNo) = Right(.Cells(lRowNo, lColNo),
Len(.Cells(lRowNo, lColNo)) - iSpacePos)
.Cells(lRowNo, lColNo) = Left(.Cells(lRowNo, lColNo),
iSpacePos - 1) 'need to following row before current one..
lRowNo = lRowNo + 1
Loop
lColNo = lColNo + 1
lRowNo = 1
Loop
.Range("A1:IV1").EntireColumn.AutoFit 'Should use Used Range here?
'Dim i As Integer 'Used to check actual columnwidth in debugging
'For i = 1 To 30
' Cells(12, i) = "W= " & Format(Cells(12, i).ColumnWidth, "0.0")
'Next i
'Load up the column widths into the array
ReDim dColHeaderWidth(iFinalCol)
For lColNo = 1 To iFinalCol
dColHeaderWidth(lColNo) = .Cells(1, lColNo).ColumnWidth
Next lColNo
End With
If bHTTPwindow = True Then
oNewSheet.Visible = False
Else
Workbooks(sNewWkBk).Close savechanges:=False
End If
End Sub
Function sFindFormat(sFormatType)
Dim vMatch
Dim msg
Dim vResult
vMatch = Application.Match(sFormatType,
ThisWorkbook.Worksheets("Format_Choice").Range("A:A"), 0)
If IsError(vMatch) = True Then
msg = "The value " & Chr(34) & sFormatType & Chr(34) & " is not
found in the data lookup table " _
& vbCr & "Do you want to use a default value (else macro will
stop)?"
' MsgBoxTitle = " WARNING on Combined Project Code " & Chr(34) &
CombinationCode & Chr(34)
vResult = MsgBox(msg, vbYesNo + vbCritical, "Cannot find value")
If vResult = vbYes Then
Select Case sFormatType
Case "Integer"
sFindFormat = "0_);-0_);0_);"
Case "Currency"
sFindFormat = "#,##0.00_);[Red]-#,##0.00_)"
Case "Date"
sFindFormat = "d-mmm-yy_)"
Case "DT"
sFindFormat = "d-mmm-yy hh:mm AM/PM_)"
End Select
End If
Exit Function
End If
sFindFormat = ThisWorkbook.Worksheets("Format_Choice").Cells(vMatch,
2).NumberFormat
End Function
Sub FormatData_NOT_VISIBLE(Optional vDummy As Integer) 'Dummy to make
"invisible")
Dim bPrintGridLines As Boolean
With ActiveWorkbook.ActiveSheet
If .PageSetup.PrintTitleRows = "" And iHeaderRow > 0 Then 'iHeaderRow >
0 added 20 Dec 02
If .UsedRange.Rows.Count > 35 Then 'not worth setting if a small
spreadsheet
.PageSetup.PrintTitleRows = "$" & iHeaderRow & ":" & "$" &
iHeaderRow 'amended 26 July 02
End If
End If
If WksExists("Format_Choice") = True Then
bPrintGridLines = WorksheetFunction.VLookup("Gridlines",
ThisWorkbook.Sheets("Format_Choice").Range("A:B"), 2, 0)
Else
bPrintGridLines = True
End If
If bPrintGridLines = True Then
' If bTimerOn Then
' Dim StartTime1
' StartTime1 = Now
' End If
If iHeaderRow > 0 Then
With .Cells(iHeaderRow, 1).CurrentRegion
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End If
'do not comment out
'the "if" statement is to avoid setting the PrintGridlines
needlessly
With .PageSetup
If .PrintGridlines = False Then
.PrintGridlines = True
End If
End With
End If
'Section to Replace Project Activity codes "03" output as "3" - no
longer required -will be in CSV files?
If iHeaderRow > 0 Then 'this is not needed as the proc. is not called
if iheaderrow = 0 'TPC 17 July 2003
For iCol = 1 To iFinalCol
If .Cells(iHeaderRow, iCol) = "Activity" And iCol > 2 Then
'iCol >2 to prevent error on col 1 etc and minimise chance
of formatting "wrong" column
If Left(Cells(iHeaderRow, iCol - 1), 4) = "Proj" Then
'this must come first
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="00", _
Replacement:="'00", LookAt:=xlWhole,
SearchOrder:=xlByRows, MatchCase:=False
'this stops the problem of a second quote (ASCII 39)
being placed at the beginning of the "00"
'solution supplied by Tom Ogilvy on 18 July 03 - note
this: LookAt:=xlPart, as opposed to xlWhole
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace _
What:="'00", Replacement:="00", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="0", _
Replacement:="'00", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="3", Replacement:="'03", _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
.Range(.Cells(iFirstDataRow, iCol), .Cells(lFinalRow,
iCol)).Replace What:="8", Replacement:="'08", _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
End If
'Ensuring the defaults on find are set to part-word, and not
match-case
'may not be required here anymore as repeated below - tpc 28
June 03
End If
Next iCol
End If
On Error Resume Next
.Cells.Replace What:="£", Replacement:=" £", LookAt:=xlPart,
SearchOrder _
:=xlByRows, MatchCase:=False
On Error GoTo 0
'tpc 28 June 03
'Ensuring the defaults on find are set to part-word, and not match-case
Range("AA1000:AA1002").Replace What:="", Replacement:="",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End With
End Sub
Private Function HeaderRowNo(oSheet As Object) 'Need to pass object in case
of HTTP windows...
Dim lRow
Dim iLastDataCol As Integer
Dim lFinalRow
Dim iStoreRowNo As Integer
Dim rHeaderCurrRegion As Range
Dim lHeaderCurrRegionLastRow As Long
Dim iHeaderCurrRegionLastCol As Integer
sErrorMsg = ""
'use this in generalised function for last row
iLastDataCol = oSheet.Cells.Find("*", [A1], , , xlByColumns,
xlPrevious).Column
lFinalRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
With oSheet
lRow = 1
Do Until lRow > WorksheetFunction.Max(40, lFinalRow)
'first test is for all cells in a given row to be non-blank
'second tests that all but one cell are non-blank (for outputs of 4
or more columns)
If WorksheetFunction.CountA(.Rows(lRow)) = iLastDataCol Or _
WorksheetFunction.CountA(.Range(.Cells(lRow, 2),
..Cells(lRow, iLastDataCol))) = iLastDataCol - 1 Then
'
' (iLastDataCol > 3 And _
' WorksheetFunction.CountA(.Rows(lRow)) = iLastDataCol - 1)
Then
iStoreRowNo = lRow
Exit Do
End If
lRow = lRow + 1
Loop
'Test here for Current Region extending to last right hand cell
If iStoreRowNo > 0 Then
Set rHeaderCurrRegion = .Cells(iStoreRowNo, 2).CurrentRegion
lHeaderCurrRegionLastRow = rHeaderCurrRegion.Row +
rHeaderCurrRegion.Rows.Count - 1
iHeaderCurrRegionLastCol = rHeaderCurrRegion.Column +
rHeaderCurrRegion.Columns.Count - 1
If lHeaderCurrRegionLastRow < lFinalRow Then
sErrorMsg = "Theoretical header row is " & iStoreRowNo & ". The
last row of the <current region> of header is Row " _
& lHeaderCurrRegionLastRow & " and is less"
sErrorMsg = sErrorMsg & vbCr & "than the very last row of the
worksheet itself, which is Row " & lFinalRow _
& " - therefore cannot validly set the header." & vbCr &
vbCr
iStoreRowNo = 0
ElseIf iHeaderCurrRegionLastCol < iLastDataCol Then
sErrorMsg = "Theoretical header row is " & iStoreRowNo & ". The
last column of the <current region> of header is Column " _
& ColConv(iHeaderCurrRegionLastCol) & " and is less"
sErrorMsg = sErrorMsg & vbCr & "than the very last column of the
worksheet itself," _
& " which is Column " & ColConv(iLastDataCol) & " -
therefore cannot validly set the header." & vbCr & vbCr
'sErrorMsg = "Last col of the <current region> header less than
main spreadsheet itself- cannot set header"
iStoreRowNo = 0
End If
End If
End With
If iStoreRowNo = 0 Then
sErrorMsg = sErrorMsg & "Macro could not properly determine the header
row for data." & vbCr
sErrorMsg = sErrorMsg & "This may be because data was added to the RHS
or bottom after its creation." & vbCr
sErrorMsg = sErrorMsg & "NOTE: it is best to run this macro at the
earliest opportunity after obtaining data." & vbCr
Debug.Print "The HeaderRow could not be set - macro quitting."
End If
HeaderRowNo = iStoreRowNo
End Function
Private Function ColConv(ColNo As Integer)
'No need to declare as public if in same module
If ColNo > 0 And ColNo < 27 Then
ColConv = Chr(65 + (ColNo - 1) Mod 26)
ElseIf ColNo > 26 And ColNo < 257 Then
ColConv = Chr(65 + Int(ColNo / 26) - 1) & Chr(65 + (ColNo - 1) Mod 26)
Else
ColConv = "{Error Value - supply valid column number}"
End If
End Function
Function WksExists(wksName As String) As Boolean
On Error Resume Next
'Note incusion of ThisWorkbook qualifier below
WksExists = CBool(Len(ThisWorkbook.Worksheets(wksName).Name) > 0)
End Function