Eloise T
Active Member
I have a multi-sheet workbook. Each spreadsheet tab in the workbook represents an individual. The data consists of 10 columns on each tab and starts in Row 3. So far with the help of various friends, many from Chandoo, I have cobbled together a VBA that "adjusts" the data (see VBA code). Each week I add rows of data and then run the VBA to make the adjustments so I don't have to manually.
My next effort is to add to another module to the VBA code to change the font and font size from whatever it may be to Calibri font, font size 11.
The VBA code (the new module SIX) I believe should look similarly to the following:
The code of the currently working VBA that the above needs to fit in is as follows:
Thanks for looking.
My next effort is to add to another module to the VBA code to change the font and font size from whatever it may be to Calibri font, font size 11.
The VBA code (the new module SIX) I believe should look similarly to the following:
Code:
'Sub Calibri&11()
For Each cll In ws.Range(ws.Cells(3, "A:H"), ws.Cells(ws.Rows.Count, "A:H").End(xlUp)).Cells
With cll
x = Evaluate("MIN(IFERROR(FIND(ROW(10:99)," & .Address(0, 0, , 1) & "),""""))")
If x > 0 Then
With .Characters(Start:=x, Length:=30).Font
.Font.Name = "Calibri"
.Font.Size = 11
End With
End If
End With
Next cll
'End SubThe code of the currently working VBA that the above needs to fit in is as follows:
Code:
Sub ChangeCase()
' ChangeCase is five VBA modules in one. See Subs below: TRIMnCLEAN(), ChangeCase(), REDnBOLD(), DateChange(), and CurrencyFix.
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Formula Info" And ws.Name <> "Dale Purdy" Then
' If ws.Name <> "Formula Info" And ws.Name <> "Next Tech" Then Note: to add more just put (And ws.Name <> "name") before Then
' Change "Formula Info" sheet name or you can use sheet index# instead of name.
If ws.Cells(Rows.Count, 3).End(xlUp).Row > 2 Then
' The 3 in (Rows.Count, 3) tells this Subroutine to start in the 3rd row.
' This line was added to "fix" Error 400 which was caused by blank tab(s).
' The "Next Tech" tab has no data, and its header is in row 2.
' The part which returns the last row of data is: ws.Cells(Rows.Count, 3).End(xlUp).Row
' which will return 3 or more as long as the worksheet has data; thus subtracting 2 from
' this value returns any number from 1 upwards. However, when the worksheet has no data,
' the above code will return 2, and subtracting 2 from this = 0, which is an invalid row
' number in Excel. To check this, we test whether the value returned by the above code
' is greater than 2; if so, we proceed further, else we exit.
'ONE-------------------------------------
' Sub TRIMnCLEAN()
With ws.[A3:D3].Resize(ws.Cells(Rows.Count, 3).End(xlUp).Row - 2)
' > > > This VBA removes leading and trailing spaces in the array of Columns A through D.
' A3:D3 array tells where to apply change(s). (Rows.Count, 3) tells in which column to start.
' .Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(#),"""")", "#", .Address)) removes leading and trailing spaces.
' Added CLEAN to remove leading and trailing ASCII characters 0-31.
.Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(CLEAN(#)),"""")", "#", .Address))
End With
' End Sub
'TWO-------------------------------------
' Sub ChangeCase()
With ws.[E3:F3].Resize(ws.Cells(Rows.Count, 3).End(xlUp).Row - 2)
' > > > This VBA changes all characters in the array defined by Columns E and F to UPPER case.
' E3:F3 array tells where to apply change(s). (Rows.Count, 3) tells in which column to start.
.Value = .Parent.Evaluate(Replace("IF(#>"""",UPPER(#),"""")", "#", .Address))
End With
' End Sub
'THREE----------------------------------- Immediate ?workbooks.Count ? application.StartupPath
' Sub REDnBOLD()
For Each cll In ws.Range(ws.Cells(3, "C"), ws.Cells(ws.Rows.Count, "C").End(xlUp)).Cells
' > > > This VBA segment changes the TV Model screen size between 70 and 90 inches to red and Bold and
' starts in Row 3, Column C, and applies to each tab in the Excel workbook, except for tab "Formula Info" tab.
With cll
x = Evaluate("MIN(IFERROR(FIND(ROW(10:99)," & .Address(0, 0, , 1) & "),""""))")
If x > 0 Then
y = CLng(Mid(cll.Value, x, 2))
If y >= 70 And y <= 90 Then
With .Characters(Start:=x, Length:=2).Font
.FontStyle = "Bold"
.Color = -16776961
End With
End If
End If
End With
Next cll
' End Sub
'FOUR-----------------------------------
' Sub DateChange()
' constants
' Const ksFormat = "mm/dd/yyyy"
' > > > This VBA segment changes the dates in Column G from whatever the format happens to be to "mm/dd/yyyy"
' declarations
Dim lRow As Long, iColumn As Integer, lRowest As Long
' start 1Row starts at row 3, iColumn starts at column G(7)
lRow = 3
iColumn = 7
' process
With ws
lRowest = .Cells(.Rows.Count, iColumn).End(xlUp).Row
Do While lRow <= lRowest
' Debug.Print lRow
With .Cells(lRow, iColumn)
' If Len(.Cells(lRow, iColumn).Value) > 0 Then
If .NumberFormat <> "mm/dd/yyyy" Then .NumberFormat = "mm/dd/yyyy"
lRow = lRow + 1
End With
Loop
End With
' End Sub
'FIVE------------------------------------ Columns("E:E").NumberFormat = "$#.##0"
' Sub CurrencyFix()
' > > > This VBA segment changes the currency in Column H from whatever the format happens to be to "$#,##0"
' declarations
'' Dim lRow As Long, iColumn As Integer, lRowest As Long
'' Dim ws As Worksheet
' start 1Row starts at row 3, iColumn starts at column H(8)
lRow = 3
iColumn = 8
' process
With ws
lRowest = .Cells(.Rows.Count, iColumn).End(xlUp).Row
Do While lRow <= lRowest
' Debug.Print lRow
With .Cells(lRow, iColumn)
' If Len(.Cells(lRow, iColumn).Value) > 0 Then
If .NumberFormat <> "$#,##0" Then .NumberFormat = "$#,##0"
lRow = lRow + 1
End With
Loop
End With
' End Sub
'SIX-------------------------------------
' Sub Font&SizeFix()
' > > > This VBA segment (when done) will change the font and font size in Columns A thru J from whatever to Calibri and 11.
' .Font.Name = "Calibri"
' .Font.Size = 11
'-----------If ws.Cells(Rows.Count, 3).End(xlUp).Row > 2 Then
End If
'-------If ws.Name <> "Formula Info" And ws.Name <> "Next Tech" Then
End If
Next
'3-BEEPS-TO-SIGNAL-END--------------------------------
Beep
' Pause a second before engaging the next Beep so they don't run together and sound like only one Beep.
Application.Wait Now + TimeValue("0:00:01")
Beep
' Pause a second before engaging the next Beep so they don't run together and sound like only one Beep.
Application.Wait Now + TimeValue("0:00:01")
Beep
End SubThanks for looking.
