How to eliminate 0s from columns

[kin]

Hi I d like a piece of code that takes out of columns 0s because they are used in the average function and give wrong results

 

[Jonmo1]

Are the 0's actual cell values, or are they the result of a formula?

If they are actual values, use find/replace to replace 0's with nothing.
Make sure to put a check on "Match Entire Cell Contents" in the Find/Replace options


If they are formula, I would adjust the formula to return "" instead of 0
Post the formula..

 

[kin]

actually i d like to use it within the following


Sub ReorgData()
' hiker95, 05/31/2011
'
Dim w1 As Worksheet, wR As Worksheet
Dim c As Range, firstaddress As String, T, tt As Long
Dim Area As Range, SR As Long, ER As Long, LC As Long, LR As Long, LR2 As Long, NC As Long, ColName As String
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
LC = w1.Cells(1, Columns.count).End(xlToLeft).Column
w1.Columns("A:B").Copy wR.Range("A1")
w1.Columns(LC).Copy wR.Range("C1")
wR.Activate
tt = Application.CountIf(wR.Columns(2), "TOTAL")
ReDim T(1 To tt)
tt = 0
With Columns(2)
Set c = .Find("TOTAL", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
c.Interior.Pattern = xlNone
Rows(c.Row + 1).Insert
tt = tt + 1
T(tt) = c.Row
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
wR.Rows(2).Insert
For Each Area In Range("B3", Range("B" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
With Area
SR = .Row
ER = SR + .Rows.count - 1
Range("A" & SR & ":A" & ER).MergeCells = False
Range("A" & SR).AutoFill Destination:=Range("A" & SR & ":A" & ER)
End With
Next Area
wR.Rows(2).Delete
For tt = UBound(T) To LBound(T) Step -1
wR.Rows(T(tt)).Delete
Next tt
On Error Resume Next
Range("C1", Range("C" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
wR.Columns(2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns(5), Unique:=True
wR.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns(6), Unique:=True
LR = wR.Cells(Rows.count, 6).End(xlUp).Row
NC = 5
For tt = 2 To LR Step 1
NC = NC + 1
With Cells(1, NC)
.Value = Cells(tt, 6) & " " & Cells(1, 3)
.Font.Bold = True
End With
Next tt
Range(Cells(2, 6), Cells(LR, 6)).Clear
LR = Cells(Rows.count, 2).End(xlUp).Row
LR2 = Cells(Rows.count, 5).End(xlUp).Row
Range("F2").Formula = "=SUMPRODUCT(--($A$2:$A$" & LR & "=LEFT(F$1,FIND("" "",F$1)-1)),--($B$2:$B$" & LR & "=$E2),--($C$2:$C$" & LR & "))"
Range("F2").AutoFill Destination:=Range("F2:F" & LR2)
LC = Cells(1, Columns.count).End(xlToLeft).Column
If LC > 6 Then
ColName = Replace(Cells(1, LC).Address(0, 0), 1, "")
Range("F2:F" & LR2).AutoFill Destination:=Range("F2:" & ColName & LR2)
With Range("F2:" & ColName & LR2)
.Value = .Value
.HorizontalAlignment = xlCenter
End With
Else
With Range("F2:F" & LR2)
.Value = .Value
.HorizontalAlignment = xlCenter
End With
End If
Columns("A:D").Delete
wR.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 

[Jonmo1]

You can also use an array formula enterd with CTRL + SHIFT + ENTER

=AVERAGE(IF(range<>0,range))