I'm trying to get VBA to evaluate a formula as it goes over a loop. The portion that fails is the Evaluate() function itself, or at least the syntax I'm using.
Worksheets("Sheet2").Range("C2").Offset(All, 0) = _
Evaluate("((SUMPRODUCT(SUBTOTAL(2,OFFSET(PercentMet!$I$2,ROW(PercentMet!$I$2:$I$27301)-ROW(PercentMet!$H$2),0)),PercentMet!$I$2:$I$27301,PercentMet!$G$2:$G$27301)/SUMPRODUCT(SUBTOTAL(9,OFFSET(PercentMet!$G$2,ROW(PercentMet!$G$2:$G$27301)-ROW(PercentMet!$G$2),0)),--(PercentMet!$I$2:$I$27301<>""NA""))))")
The portion that fails is the ""NA"" at the end of the formula. Using this formula each cell equates to #VALUE!
If I remove the Evaluate portion the formula works as I want, but I need Evaluate because I'm looping through various filters and each value is unique.
Entire Code is Below:
Sub EthFilter()
Application.ScreenUpdating = False
Dim EthName As Range, GradeName As Range, Rate As Variant, Grade As Variant
Dim One As Integer, Zero As Integer, All As Integer
Set EthName = Worksheets("Sheet2").Range("J1")
Set GradeName = Worksheets("Sheet2").Range("K1")
One = 0
All = 0
For Each Raeth In Range("J1:J7")
Zero = 0
Rate = EthName.Offset(One, 0)
With Worksheets("PercentMet")
.AutoFilterMode = False
With .Range("$A$1:$O$27301")
.AutoFilter Field:=6, Criteria1:=Rate
For Each Grades In Range("B2:B9")
Grade = GradeName.Offset(Zero, 0).Value
With Worksheets("PercentMet")
With .Range("$A$1:$O$27301")
.AutoFilter Field:=5, Criteria1:=Grade
Worksheets("Sheet2").Range("C2").Offset(All, 0) = _
Evaluate("((SUMPRODUCT(SUBTOTAL(2,OFFSET(PercentMet!$I$2,ROW(PercentMet!$I$2:$I$27301)-ROW(PercentMet!$H$2),0)),PercentMet!$I$2:$I$27301,PercentMet!$G$2:$G$27301)/SUMPRODUCT(SUBTOTAL(9,OFFSET(PercentMet!$G$2,ROW(PercentMet!$G$2:$G$27301)-ROW(PercentMet!$G$2),0)),--(PercentMet!$I$2:$I$27301<>""NA""))))")
End With
End With
All = All + 1
Zero = Zero + 1
Next Grades
End With
End With
One = One + 1
Next Raeth
Application.ScreenUpdating = True
End Sub
If the length of the formula is a problem then instead of this (line breaks added for clarity):
Worksheets("Sheet2").Range("C2").Offset(All, 0) = Evaluate(
"((SUMPRODUCT(SUBTOTAL(2,OFFSET(PercentMet!$I$2,ROW(PercentMet!$I$2:$I$27301)-
ROW(PercentMet!$H$2),0)),PercentMet!$I$2:$I$27301,PercentMet!$G$2:$G$27301)/
SUMPRODUCT(SUBTOTAL(9,OFFSET(PercentMet!$G$2,ROW(PercentMet!$G$2:$G$27301)-
ROW(PercentMet!$G$2),0)),--(PercentMet!$I$2:$I$27301<>""NA""))))")
you can use this form:
Worksheets("Sheet2").Range("C2").Offset(All, 0) = Worksheets("PercentMet").Evaluate(
"((SUMPRODUCT(SUBTOTAL(2,OFFSET($I$2,ROW($I$2:$I$27301)-
ROW($H$2),0)),$I$2:$I$27301,$G$2:$G$27301)/
SUMPRODUCT(SUBTOTAL(9,OFFSET($G$2,ROW($G$2:$G$27301)-
ROW($G$2),0)),--($I$2:$I$27301<>""NA""))))")
Since all the inputs come from the same sheet you can use that sheet's Evaluate method and the formula will be evaluated in the context of that sheet.
The default Application.Evaluate version uses whichever sheet is Active at the time of execution.
Related
I am new to VBA, facing the following problem:
I need to return certain value, returned by IF formula, based on numeric data, kept in another worksheet.
I have written something like this, however all the time when it comes to the point of running IF part, it gives me the error Type mismatch, and the problem seems to be in the values, found by vlookup. I was trying to declare it as long, variant and so on but that didn't help. However the MsgBox returnes the result from another sheet properly. Another sheet is formatted as numbers. Any ideas how to make it work?
here is the code i have for now:
Option Explicit
Sub find()
Dim lookup As String
Dim pkgWidth, pkgLength, pkgHeight, displaySize, AllHeaders, headerweight, itemweight, classify As Range
Dim lastrow As Variant
Dim cl As Range
Dim i As Integer
Dim widthh, lengthh, Heightt, display, Weight As Variant
'this part dynamically searches for the columns I need
Set AllHeaders = Worksheets("Sheet2").Range("1:1")
Set pkgWidth = AllHeaders.find("package_width")
Set pkgLength = AllHeaders.find("package_length")
Set pkgHeight = AllHeaders.find("package_height")
Set displaySize = AllHeaders.find("display_size")
Set headerweight = Worksheets("Sheet1").Range("1:1")
Set itemweight = headerweight.find("Item Weight")
Set classify = headerweight.find("AT")
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
lookup = Worksheets("Sheet1").Cells(i, 1).Value
Set cl = Worksheets("Sheet1").Cells(i, classify.Column)
'here the values are being looked up from another sheet
widthh = Application.VLookup(lookup, _
Worksheets("Sheet2").Range("A1").CurrentRegion, pkgWidth.Column, False)
lengthh = Application.VLookup(lookup, _
Worksheets("Sheet2").Range("A1").CurrentRegion, pkgLength.Column, False)
Heightt = Application.VLookup(lookup, _
Worksheets("Sheet2").Range("A1").CurrentRegion, pkgHeight.Column, False)
display = Application.VLookup(lookup, _
Worksheets("Sheet2").Range("A1").CurrentRegion, displaySize.Column, False)
Weight = Application.VLookup(lookup, _
Worksheets("Sheet1").Range("A1").CurrentRegion, itemweight.Column, False)
If display > 6 Then
If Weight < 25 Then
cl.Value = 1.01
Else
cl.Value = 1.02
End If
Else
If widthh >= 1970 Or lengthh >= 1970 Or Heightt >= 1970 Then
If Weight <= 8 Then
cl.Value = 3.01
Else
If Weight >= 35 Then
cl.Value = 3.02
Else
cl.Value = 3.03
End If
End If
Else
If Weight <= 3 Then
cl.Value = 5.01
Else
If Weight >= 8 Then
cl.Value = 5.03
Else
cl.Value = 5.02
End If
End If
End If
End If
Next i
End Sub
When using Application.VLookup (or any of its variants) you must take into account that it can return #N/A, as explained in the documentation:
If lookup_value is smaller than the smallest value in the first column of table_array, VLOOKUP returns the #N/A error value.
If for instance display gets that value, then the expression display > 6 will give you the Type mismatch error.
So to prevent that, either change the logic of your code so that VLookup is guaranteed to not return #N/A (if this is possible in your case, I cannot say), or test for this error value, like this:
If IsError(display) Then
' Treat the error condition...
ElseIf display > Then
' ...etc.
The same precaution may be needed for other variables that get the result of a VLookup call.
I'm trying to create a VBA function that starts from the bottom of a range, and returns the first value that's different from the value at the bottom.
Example:
In the above table, I'd like to be able to grab the last value in the "Month" column (11), and iterate to the top until the value 10 is reached, and return that value.
I just started looking into VBA 3 days ago and am very unfamiliar with the language so I'm still trying to grok the syntax.
I have no doubt that my thinking is fuzzy with this, so I'd really appreciate feedback on my errors.
Here's what I have right now:
Code:
Function NextValue(num1 As Range)
For c = num1.End(xlDown) To num1.Item(1)
If Cells(c, 1) <> num1.End(xlDown) Then
NextValue = Cells(c, 1)
Exit For
End If
Next c
End Function
In case it's not clear, here's a description of what I'm trying to do, line-by-line.
1). Initiate a For-Loop that begins at the end of a range and decrements to the top
2). Check if that cell does not match the last value in that column
3). If it does not, then set the value of the function to that value
4). Terminate If statements, For loops, and end the function.
Your help is greatly appreciated.
Try this:
Function NextValue(num1 As Range) as Integer
Dim y As Integer
'get the last cell from num1
Set num1 = num1.End(xlDown)
y = -1
Do Until num1.Offset(y, 0).Value <> num1.Value
y = y - 1
Loop
'set function return to the different cell
NextValue = num1.Offset(y, 0).value
End Function
This will handle both compact ranges and disjoint ranges:
Option Explicit
Public Function SomethingElse(rng As Range) As Variant
Dim r As Range, values() As Variant
Dim i As Long, strvalue As Variant
ReDim values(1 To rng.Count)
i = 1
For Each r In rng
values(i) = r.Value
i = i + 1
Next r
strvalue = values(rng.Count)
For i = rng.Count To 1 Step -1
If values(i) <> strvalue Then
SomethingElse = values(i)
Exit Function
End If
Next i
SomethingElse = CVErr(xlErrNA)
End Function
Not clear to me if you want an UDF or a code to be used in a macro
in the first case you've already been given answers
in the latter case you may want to consider these two options:
Public Function FirstDifferent(rng As Range) As Variant
With rng.Parent.UsedRange
With Intersect(.Resize(, 1).Offset(, .Columns.Count), rng.EntireRow)
.Value = rng.Value
.RemoveDuplicates Array(1)
FirstDifferent = .Cells(.Rows.Count, 1).End(xlUp).Offset(-1).Value
If FirstDifferent = .Cells(.Rows.Count, 1) Then FirstDifferent = "#N/A"
.ClearContents
End With
End With
End Function
Public Function FirstDifferent(rng As Range) As Variant
With rng.Resize(, 1)
.AutoFilter Field:=1, Criteria1:=.Cells(.Rows.Count, 1)
FirstDifferent = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Cells(1, 1).Offset(-1).Value ' = 0 '<-- if any rows filtered other than headers one then change their column "B" value to zero
If FirstDifferent = .Cells(.Rows.Count, 1) Then FirstDifferent = "#N/A"
.Parent.AutoFilterMode = False
End With
End Function
As the title says. Is there any function or VBA code which does the same function as a countif and is a lot faster. Currently in the middle of massive countif and it is just eating up my CPU.
It is just a basic countif inside the worksheet. Not in VBA.
=countif(X:X,Y) However the lists are massive. So both lists are around 100,000~ rows
If you can do without a count of the occurances and simply wish to check if the value x exists in the column of y's, then returning a boolean TRUE or FALSE with the ISNUMBER function evaluating a MATCH function lookup will greatly speed up the process.
=ISNUMBER(MATCH(S1, Y:Y, 0))
Fill down as necessary to catch all returns. Sort and/or filter the returned values to tabulate results.
Addendum:
Apparently there is. The huge improvement in the MATCH function calculation times over the COUNTIF function made me wonder if MATCH couldn't be put into a loop, advancing the first cell in its lookup_array parameter to the previously returned row number plus one until there were no more matches. Additionally, subsequent MATCh calls to lookup the same number (increasing the count) could be made to increasingly smaller lookup_array cell ranges by resizing (shrinking) the height of the column by the returned row number as well. If the processed values and their counts were stored as keys and items in a scripting dictionary, duplicate values could be instantly resolved without processing a count.
Sub formula_countif_test()
Dim tmr As Double
appOFF
tmr = Timer
With Sheet2.Cells(1, 1).CurrentRegion
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
.Cells(1, 3).Resize(.Rows.Count, 1).FormulaR1C1 = _
"=countif(c1, rc2)" 'no need for calculate when blocking in formulas like this
End With
End With
Debug.Print "COUNTIF formula: " & Timer - tmr
appON
End Sub
Sub formula_match_test()
Dim rw As Long, mrw As Long, tmr As Double, vKEY As Variant
'the following requires Tools, References, Microsoft Scripting Dictionary
Dim dVALs As New Scripting.dictionary
dVALs.CompareMode = vbBinaryCompare 'vbtextcompare for non-case sensitive
appOFF
tmr = Timer
With Sheet2.Cells(1, 1).CurrentRegion
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
For rw = 1 To .Rows.Count
vKEY = .Cells(rw, 2).Value2
If Not dVALs.Exists(vKEY) Then
dVALs.Add Key:=vKEY, _
Item:=Abs(IsNumeric(Application.Match(vKEY, .Columns(1), 0)))
If CBool(dVALs.Item(vKEY)) Then
mrw = 0: dVALs.Item(vKEY) = 0
Do While IsNumeric(Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0))
mrw = mrw + Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0)
dVALs.Item(vKEY) = CLng(dVALs.Item(vKEY)) + 1
Loop
End If
.Cells(rw, 3) = CLng(dVALs.Item(vKEY))
Else
.Cells(rw, 3) = CLng(dVALs.Item(vKEY))
End If
Next rw
End With
End With
Debug.Print "MATCH formula: " & Timer - tmr
dVALs.RemoveAll: Set dVALs = Nothing
appON
End Sub
Sub appON(Optional ws As Worksheet)
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub appOFF(Optional ws As Worksheet)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub
I used 10K rows with columns A and B filled by RANDBETWEEN(1, 999) then copied and pasted as values.
Elapsed times:
Test 1¹ - 10K rows × 2 columns filled with RANDBETWEEN(1, 999)
COUNTIF formula: 15.488 seconds
MATCH formula: 1.592 seconds
Test 2² - 10K rows × 2 columns filled with RANDBETWEEN(1, 99999)
COUNTIF formula: 14.722 seconds
MATCH formula: 3.484 seconds
I also copied the values from the COUNTIF formula into another column and compared them to the ones returned by the coded MATCH function. They were identical across the 10K rows.
¹ More multiples; less zero counts
² More zero counts, less multiples
While the nature of the data clearly makes a significant difference, the coded MATCH function outperformed the native COUNTIF worksheet function every time.
Don't forget the VBE's Tools ► References ► Microsoft Scripting Dictionary.
I use the following technique in place of COUNTIF. I have 115k rows of data and the calculation step was basically instantaneous, but you spend a bit more time setting it up.
Make a copy of the data you want to count and put in column A of a new sheet.
Sort the data you want to count (such that all identical items are next to each other).
Put the following formula in column B =IF(A2=A1,B2+1,1). Populate the column with the formula then paste value.
Put a sequential number in column C (just 1,2,3,4 ... up to the number of rows you have)
Sort everything by column C descending. The result is that in column B, the biggest count comes first.
Select column A and B, then use "Remove Duplicate" function. Now you're left with one entry per distinct row of Data and the biggest count for each.
Back in your real data sheet, use =VLOOKUP(A2,Sheet2!A:B,2,false) to get the count.
If you want to make a macro out of this, simply use Record Macro while performing the above actions.
Try sumproduct(countif(x:x,y:y))
It’s slightly faster but by how much I am not sure.
Also let us know if you have found a better option out there.
There is an easy workaround for COUNTIF, after sorting the data. You may add this to your VB Script, and run. For data with around 1 lakh line items, normal COUNTIF takes almost 10-15 mins. This script will get the counts in <10 secs.
Sub alternateFunctionForCountIF()
Dim DS As Worksheet
Set DS = ThisWorkbook.ActiveSheet
Dim lcol As Integer
lcol = DS.Cells(1, Columns.Count).End(xlToLeft).Column
Dim fieldHeader As String
Dim lrow As Long, i As Long, j As Long
Dim countifCol As Integer, fieldCol As Integer
fieldHeader = InputBox("Enter the column header to apply COUNTIF")
If Len(fieldHeader) = 0 Then
MsgBox ("Invalid input. " & Chr(13) & "Please enter the column header text and try again")
Exit Sub
End If
For i = 1 To lcol
If fieldHeader = DS.Cells(1, i).Value Then
fieldCol = i
Exit For
End If
Next i
If fieldCol = 0 Then
MsgBox (fieldHeader & " could not be found among the headers. Please enter a valid column header")
Exit Sub
End If
countifCol = fieldCol + 1
lrow = DS.Cells(Rows.Count, "A").End(xlUp).Row
DS.Range(DS.Cells(1, countifCol).EntireColumn, DS.Cells(1, countifCol).EntireColumn).Insert
DS.Cells(1, countifCol) = fieldHeader & "_count"
DS.Sort.SortFields.Clear
DS.Sort.SortFields.Add Key:=Range(DS.Cells(2, fieldCol), DS.Cells(lrow, fieldCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DS.Sort
.SetRange Range(DS.Cells(1, 1), DS.Cells(lrow, lcol))
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim startPos As Long, endPos As Long
Dim checkText As String
For i = 2 To lrow
checkText = LCase(CStr(DS.Cells(i, fieldCol).Value))
If (checkText <> LCase(CStr(DS.Cells(i - 1, fieldCol).Value))) Then
startPos = i
End If
If (checkText <> LCase(CStr(DS.Cells(i + 1, fieldCol).Value))) Then
endPos = i
For j = startPos To endPos
DS.Cells(j, countifCol) = endPos - startPos + 1
Next j
End If
Next i
MsgBox ("Done")
End Sub
I am trying to create a macro that will find the maximum value (i.e. the largest) for specific columns in row.
Figure 1:
For example, In FIGURE 1 I have shown a simple example table ranging A1 to K12. Where the top 2 rows represent ‘Height’ and ‘Year’ respectively. And they are always in ascending order. The figure shows 2 years data and I am trying to create the maximum for each height between years. I have highlighted in red text what I am trying to do. For example, cell L3 is the Max of B3 and G3 (i.e. =MAX(B3,G3)) and similarly all the cells for range L3:P12 in red are the maximum values for each heights.
I know I can do this easily just by manually calculating using Max(cell1,cell2) function or by using the following Macro:
Sub test()
Range("G1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Range("L1").Select
ActiveSheet.Paste
Range("L3").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=MAX(RC[-10],RC[-5])"
Range("L3").Select
Selection.AutoFill Destination:=Range("L3:P3"), Type:=xlFillDefault
Range("L3:P3").Select
Selection.AutoFill Destination:=Range("L3:P12")
Range("L3:P12").Select
End Sub
But my actual table is far more larger with many more years of data with more heights and I will be running this in a loop for many spreadsheets. There for the number of rows and columns can vary. So I am just wondering how I can adopt a dynamic argument that will dynamically calculate the max based on the top two rows (i.e. height and year).
I was thinking if any way I could set a range for the top row as the height will be always increasing until the next year when it restart from the lowest value again. My plan was to then try to put some conditions to calculate the max values and autofill the range. But I am just not able to even define the range as I am strugling to logically plan this code. The following is what I have tried and I would really appreciate any guidance on how logically I could achieve this problem. Many thanks in Advance!
Sub test()
Dim LR As Long, i As Long, r As Range
LR = Range("1" & Columns.Count).End(xlToRight)
For i = 1 To LR
If Range("1" & i).Value > 10 Then
If r Is Nothing Then
Set r = Range("1" & i)
Else
Set r = Union(r, Range("1" & i))
End If
End If
Next i
r.Select
End Sub
Due to the unlimited possibility of height values, using a class was the best solution that I could think of for now. Hopefully this provides a good foundation to build from.
In a class module named 'HeightClass':
Option Explicit
Dim rngRangeStore As Range
Dim sValueStore As String
Public Property Set rngRange(rngInput)
Set rngRangeStore = rngInput
End Property
Public Property Get rngRange() As Range
Set rngRange = rngRangeStore
End Property
Public Property Let sValue(sInput As String)
sValueStore = sInput
End Property
Public Property Get sValue() As String
sValue = sValueStore
End Property
Then in a standard Module:
Option Explicit
Sub Get_Max()
Dim lRecord As Long, lRange As Long, lLastRecord As Long, lLastColumn As Long
Dim colRanges As New Collection
Dim clsRange As HeightClass
'Find Last used column in the year row
lLastColumn = Rows(2).Find(What:="*", SearchDirection:=xlPrevious).Column
'Find last used row in column 1
lLastRecord = Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
For lRange = 2 To lLastColumn
On Error Resume Next
Set clsRange = Nothing
Set clsRange = colRanges(Trim$(Cells(1, lRange).Value))
On Error GoTo 0
If Not clsRange Is Nothing Then
'Add to existing range
Set clsRange.rngRange = Union(clsRange.rngRange, Cells(1, lRange))
Else
'Add range to colletion in order of smallest to largest
Set clsRange = New HeightClass
Set clsRange.rngRange = Cells(1, lRange)
clsRange.sValue = Cells(1, lRange).Value
If colRanges.Count = 0 Then
colRanges.Add Item:=clsRange, Key:=clsRange.sValue
Else
For lRecord = 1 To colRanges.Count
If clsRange.sValue < colRanges(lRecord).sValue Then
colRanges.Add Item:=clsRange, Key:=clsRange.sValue, Before:=colRanges(lRecord).sValue
Exit For
ElseIf lRecord = colRanges.Count Then
colRanges.Add Item:=clsRange, Key:=clsRange.sValue, After:=colRanges(lRecord).sValue
Exit For
End If
Next lRecord
End If
End If
Next lRange
'Place height headers
For lRange = 1 To colRanges.Count
With Cells(1, lLastColumn + lRange)
.Value = colRanges(lRange).sValue
.Font.Color = vbRed
End With
Next lRange
'Process each record
For lRecord = 3 To lLastRecord
For lRange = 1 To colRanges.Count
With Cells(lRecord, lLastColumn + lRange)
.Value = Application.Max(colRanges(lRange).rngRange.Offset(lRecord - 1))
.Font.Color = vbRed
.NumberFormat = "0.00"
End With
Next lRange
Next lRecord
End Sub
This is written to perform the desired process on whatever sheet is in focus.
So the array formula (enter it with Ctrl+Shift+Enter)version would be, in L3 etc.:
=MAX(IF($B$1:$K$1=L$1,$B3:$K3,""))
It says:
look in the headers $B$1:$K$1 to check a match for your column's height (=L$1)
if it matches, take the value ,$B3:$K3
otherwise ignore it ,""
take the MAX of those non-ignored values
I tried this with 100 columns (5 heights * 20 years) and 1000 rows of RAND produced random numbers and the recalculation time was negligible
With some help, I've put together two functions that will work in unison to first convert all of my data from the "text" format to a "number" format. After which it will set each column to a fixed number of characters.
The two sub-routines I'm using are listed below, but I can't figure out how to omit certain rows/columns for the respective functions.
When running the psAdd function, I want to omit the first 3 rows from the range, and for the FormatFixedNumber function I want to omit several columns. The problem with the latter is that I have 1000+ columns of data and a key header row containing a 1 or 0 that represents whether the column should be converted.
How could modify this code to skip the first 3 rows in the first sub, and several columns marked with a 0 in the second?
Sub psAdd()
Dim x As Range 'Just a blank cell for variable
Dim z As Range 'Selection to work with
Set z = Cells
Set x = Range("A65536").End(xlUp).Offset(1)
If x <> "" Then
Exit Sub
Else
x.Copy
z.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
Application.CutCopyMode = False 'Kill copy mode
End If
x.ClearContents 'Back to normal
End Sub
Sub FormatFixedNumber()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To lastCol 'replace 10 by the index of the last column of your spreadsheet
With Columns(i)
.NumberFormat = String(.Cells(2, 1), "0") 'number length is in second row
End With
Next i
Application.ScreenUpdating = True
End Sub
1. First code
At the moment you are working on all the cells on a sheet with z. You can reduce this to the UsedRange - ignoring the first three rows by
forcing the UsedRange to update before using it (to avoid redunant cells)
testing if the z exceeds 3 rows
if so resize z by three rows using Offset and Resize
Sub psAdd()
Dim x As Range 'Just a blank cell for variable
Dim z As Range 'Selection to work with
ActiveSheet.UsedRange
Set z = ActiveSheet.UsedRange
If z.Rows.Count > 3 Then
Set z = z.Cells(1).Offset(3, 0).Resize(z.Rows.Count - 3, z.Columns.Count)
End If
'using Rows is better than hard-coding 65536 (bottom of xl03 - but not xl07-10)
Set x = Cells(Rows.Count,"A").End(xlUp).Offset(1)
If x <> "" Then
Exit Sub
Else
x.Copy
z.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
Application.CutCopyMode = False 'Kill copy mode
End If
x.ClearContents 'Back to normal
End Sub
2. Second code
Run a simple test on each header cell to proceed if it doesn't equal 0. Assuming that the header cell is in row 1 then
Sub FormatFixedNumber()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To lastCol 'replace 10 by the index of the last column of your spreadsheet
If Cells(1, i) <> 0 Then
With Columns(i)
.NumberFormat = String(.Cells(2, 1), "0") 'number length is in second row
End With
End If
Next i
Application.ScreenUpdating = True
End Sub