I have using this function which finds and replace the string throughout the entire workbook.
But i do not know why error is appearing "run time error: Object variable or with block variable not set" on rngCheck = Me.Range("A2:A37")
I tried alot to find the problem but its not find you help will be appreciated.
Sub FndRplce(fnd As String, rplc As String)
Dim sht As Worksheet
Dim boolStatus As Boolean
boolStatus = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, LookIn:=xlValues, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
Application.ScreenUpdating = boolStatus
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCheck As Range
Dim strOld As String
Dim strNew As String
rngCheck = Me.Range("A2:A37")
If Target.Count > 1 Then Exit Sub
If Intersect(Target, rngCheck) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
strNew = Target.Value
Application.Undo
strOld = Target.Value
Call FndRplce(strOld, strNew)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Please, try the next pieces of code:
1.Copy this one in the Sheet1 code module:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCheck As Range, strOld As String, strNew As String, lastR As Long
'Now, it calculates the last existing value in column "A:A":
'no need to adapt the code after adding records
lastR = Me.Range("A" & Me.Rows.Count).End(xlUp).Row
Set rngCheck = Me.Range("A2:A" & lastR)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, rngCheck) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
strNew = Target.Value
Application.Undo: strOld = Target.Value
Call FndRplce(strOld, strNew)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Copy the next Sub in a standard module. But take care to delete your existing one having the same name...
Sub FndRplce(fnd As String, rplc As String)
Dim sht As Worksheet, boolStatus As Boolean
boolStatus = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
Application.ScreenUpdating = boolStatus
End Sub
Please, test it and send some feedback.
Related
I use this piece of code to delete any blank rows in my excel file and then adjust the structure so there won't be a blank hole in the file.
But I found out that this part of the code put my script in an infinite loop.
Does somebody know what I can change to stop this piece of code let my script go in an infinite loop or is there maybe a better way to delete blank rows?
Dim LastRowIndex As Integer
Dim RowIndex As Integer
Dim UsedRng As Range
Set UsedRng = ActiveSheet.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
Application.ScreenUpdating = False
For RowIndex = LastRowIndex To 1 Step -1
If Application.CountA(Rows(RowIndex)) = 0 Then
Rows(RowIndex).Delete
End If
Next RowIndex
Application.ScreenUpdating = False
Dim n As Long
The hole code looks like:
Dim cell As Range
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
For Each cell In ActiveSheet.Range("C2:C" & lastRow)
S = vbNullString
If cell.Value <> vbNullString Then
v = Split(cell.Value, " ")
For Each W In v
S = S & Left$(W, 1) & "."
Next W
cell.Offset(ColumnOffset:=-1).Value = S
End If
Next cell
Application.Range("B1").Value = "tesing"
Worksheets("sheet1").Range("B1").Font.Bold = True
Columns("D").Replace What:="vander", _
Replacement:="van der", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Columns("D").Replace What:="vanden", _
Replacement:="van den", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Columns("B").Replace What:="..", _
Replacement:=".", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
'Beta code'
Dim r As Range
For Each r In ActiveSheet.UsedRange
If Not IsError(r.Value) Then
v = r.Value
If v <> vbNullString Then
If Not r.HasFormula Then
r.Value = Trim(v)
End If
End If
End If
Next r
'NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW NIEUW '
ActiveWorkbook.Worksheets("sheet1").Range("A2:Z5000").Font.Bold = False
ThisWorkbook.ActiveSheet.Cells.Range("A2:Z5000").ClearFormats
Range("A1:Z5000").Font.Color = vbBlack
Range("G2:G5000,A2:A5000,H2:H5000").Clear
Worksheets("sheet1").Columns("A:M").AutoFit
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const RolesList As String = "Testing"
Const FirstCellAddress As String = "L2"
Const Delimiter As String = "||"
Dim rng As Range
With Range(FirstCellAddress)
Set rng = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
End With
If rng Is Nothing Then
Exit Sub
End If
Dim Roles() As String: Roles = Split(RolesList, ",")
Dim dRng As Range
Dim aRng As Range
Dim cel As Range
Dim Curr() As String
Dim cMatch As Variant
Dim n As Long
Dim isFound As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If Not IsError(cel) Then
Curr = Split(cel.Value, Delimiter)
For n = 0 To UBound(Curr)
cMatch = Application.Match(Curr(n), Roles, 0)
If IsError(cMatch) Then
isFound = True
Exit For
Else
' Remove this block if you don't need case-sensitivity.
If StrComp(Curr(n), Roles(cMatch - 1), _
vbBinaryCompare) <> 0 Then
isFound = True
Exit For
End If
End If
Next n
If isFound Then
isFound = False
If dRng Is Nothing Then
Set dRng = cel
Else
Set dRng = Union(dRng, cel)
End If
End If
End If
Next cel
Next aRng
Application.ScreenUpdating = False
rng.Interior.Color = xlNone
If Not dRng Is Nothing Then
dRng.Interior.Color = vbRed
End If
Application.ScreenUpdating = True
End Sub
I replaced the code above with, it works now:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Range("A" & i & ":" & "Z" & i)
Else
Set DelRange = Union(DelRange, Range("A" & i & ":" & "Z" & i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
I have this code that I've been using (not mine). It works well with me because I know that I can change the value in sh.Rows ("x") to whatever row I want and it'll grab everything that I need. I want to make this easier for one of my co workers to use so that they wouldn't have to go into Visual Basics to edit it. Is there an easy way to make it so that it can take whatever row that's in cell B2 from every sheet and paste it into a master sheet?
Sub CopytoMaster()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
If SheetExists("Master") = True Then
MsgBox "The sheet Master already exist"
Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
If sh.UsedRange.Count > 1 Then
Last = LastRow(DestSh)
sh.Rows("7").Copy DestSh.Cells(Last + 1, 1)
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Sub CheckMaster()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
If SheetExists("Master") = True Then
MsgBox "The sheet Master already exist"
Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
If sh.UsedRange.Count > 1 Then
Last = LastRow(DestSh)
With sh.Rows("7")
DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(Sheets(SName).Name))
End Function
You can simply use the Range.Value method to grab the value of B2. Place this within the .Row() method. In other words, you would just need to change your sh.Rows("7") to sh.Rows(ws.range("B2").value).
Sub CopytoMaster()
Dim sh As Worksheet, ws As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
If SheetExists("Master") = True Then
MsgBox "The sheet Master already exist"
Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
If sh.UsedRange.Count > 1 Then
Last = LastRow(DestSh)
sh.Rows(ws.Range("B2").Value).Copy DestSh.Cells(Last + 1, 1)
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Same thing with your second procedure:
Sub CheckMaster()
Dim ws As Worksheet
...
With sh.Rows(ws.Range("B2").Value)
DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
Where ws is the worksheet object that contains the value in question. You weren't clear on if this was the same worksheet as sh or not, so if it is you can change ws to sh - otherwise, you will need to Set ws to the sheet that contains the value.
This is what I have now and it is working pretty much how I want it to.
Sub CopytoMaster2()
Dim wb As Workbook
Dim sh As Worksheet
Dim ws As Worksheet
Dim DestSh As Worksheet
Dim mainSh As Worksheet
Dim Last As Long
If SheetExists("Master") = True Then
MsgBox "The sheet Master already exist"
Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
Set wb = ActiveWorkbook
Set mainSh = wb.Sheets("Main")
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> mainSh.Name And sh.Name <> DestSh.Name Then
If sh.UsedRange.Count > 1 Then
Last = LastRow(DestSh)
sh.Rows(mainSh.Range("E7").Value).Copy DestSh.Cells(Last + 1, 1)
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Sub CheckMaster2()
Dim wb As Workbook
Dim sh As Worksheet
Dim ws As Worksheet
Dim DestSh As Worksheet
Dim mainSh As Worksheet
Dim Last As Long
If SheetExists("Master") = True Then
MsgBox "The sheet Master already exist"
Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
Set wb = ActiveWorkbook
Set mainSh = wb.Sheets("Main")
For Each sh In ThisWorkbook.Worksheets
If mainSh.Name <> sh.Name And sh.Name <> DestSh.Name Then
If sh.UsedRange.Count > 1 Then
Last = LastRow(DestSh)
With sh.Rows(mainSh.Range("E7").Value)
DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Function LastRow2(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function Lastcol2(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Function SheetExists2(SName As String, _
Optional ByVal wb As Workbook) As Boolean
On Error Resume Next
If wb Is Nothing Then Set wb = ThisWorkbook
SheetExists = CBool(Len(Sheets(SName).Name))
End Function
I have a search box that auto opens when the file is started requesting the target value. I have tried many times to write something that will hide all rows above and below the value once found, with no avail.
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
Set Rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
Unload Me
End Sub
I would like to search for EMPLID 12345, return only that row (including the header on Row 1, with all other rows hidden.
Add an autofilter.
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
Set Rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
.autofilter
.autofilter field:=1, criteria1:=EMPLID
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
Unload Me
End Sub
just plain use of Autofilter():
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
.AutoFilter field:=1, Criteria1:=EMPLID
If WorksheetFunction.Subtotal(103, .Cells) = 1 Then ' if only header row filtered -> no match found
MsgBox "Nothing found"
.Parent.AutoFilterMode = False ' remove AutoFilter and show all data
End If
End With
Unload Me
End Sub
BTW I'd suggest you some little enhancements:
limit the searching range to the actual data extensions, instead of the whole column (some 1 million row)
Don't use Unload Me inside a UserForm code. Adopt Hide.Me and move Unload Me to the Userform calling sub (the one where you place some With New MyUserform statement or the likes)
like follows:
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data")
With .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
.AutoFilter field:=1, Criteria1:=EMPLID
If WorksheetFunction.Subtotal(103, .Cells) = 1 Then ' if only header row filtered -> no match found
MsgBox "Nothing found"
.Parent.AutoFilterMode = False ' remove AutoFilter and show all data
End If
End With
End With
Me.Hide
End Sub
I like the autofilter answer just posted. But a more-literal answer that actually hides the rows, except row 1 and the one where 'Rng' is, goes like this:
Sub tst()
Dim rng As Range, bottom As Range
Set rng = [D3] ' Just example data
rng.Activate ' put cursor on rng
' Assumes Column A has data, otherwise use column with Rng in it
Set bottom = Range("A" & Rows.Count).End(xlUp) ' finds last row in A with any data in it
If rng.Row > 2 Then Range(Rows(2), Rows(rng.Row - 1)).Hidden = True ' Hide all rows above RNG
If rng.Row < bottom.Row Then Range(Rows(rng.Row + 1), Rows(bottom.Row)).Hidden = True ' Hide rows below
End Sub
Another simple way to accomplish your task.
Private Sub Summary_Click()
Dim EMPLID As String, cl As Range
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data")
For Each cl In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
If Not cl.Value = EMPLID Then
cl.EntireRow.Hidden = True
End If
Next cl
End With
End Sub
Try
Sub test()
Dim EMPLID As String
Dim rngDB As Range, Rng As Range, rngU As Range
Dim Ws As Worksheet
Dim strAddress As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
Set Ws = Sheets("Tracking Data")
With Ws
Set rngDB = .Range("e1", .Range("e" & Rows.Count).End(xlUp))
End With
With rngDB
.EntireRow.Hidden = False
Set Rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
strAddress = Rng.Address
Do
If rngU Is Nothing Then
Set rngU = Rng
Else
Set rngU = Union(rngU, Rng)
End If
Set Rng = .FindNext(Rng)
Loop While Rng.Address <> strAddress
End If
End With
If rngU Is Nothing Then
MsgBox "Nothing found"
Else
rngDB.EntireRow.Hidden = True
rngU.EntireRow.Hidden = False
End If
End Sub
Find vs Parent
To not cramp your style, I've only removed the arguments SearchDirection and MatchCase because they were using default parameters and I've added the 'Parent' part which is referring to the worksheet (Tracking Data).
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
Set rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
If Not rng Is Nothing Then
With .Parent
.Cells(2, 1).Resize(rng.Row - 2).EntireRow.Hidden = True
.Cells(rng.Row + 1, 1).Resize(.Rows.Count - rng.Row) _
.EntireRow.Hidden = True
End With
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
Unload Me
End Sub
I have two vba Code and i want to combine as single process. Need someone help please.
1st Code:
Sub DelAllZeros()
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
Set frange = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not frange Is Nothing Then
For Each c In frange
If c.Value = 0 Then
c.Formula = ClearContents
End If
Next c
End If
Set frange = Nothing
Next ws
End Sub
2nd Code:
Sub DelAllZeros1()
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
ws.Select
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next ws
End Sub
1st code will clear the "0" from formula cells and seconds code will clear non formula cells.
Try the code below (modifications inside the code comments)
Option Explicit
Sub DelAllZerosCombined()
Application.Calculation = xlCalculationManual
Dim ws As Worksheet, c As Range, Rng As Range
For Each ws In Worksheets
' set range to occupied range in worksheet (save time in loop)
Set Rng = ws.Range("A1:" & ws.Cells.SpecialCells(xlCellTypeLastCell).Address)
If Not Rng Is Nothing Then
For Each c In Rng
If c.Value = 0 Then
' unmerge "merged" cells
If c.MergeCells Then c.UnMerge
c.ClearContents
End If
Next c
End If
Set Rng = Nothing
Next ws
' resume setting
Application.Calculation = xlCalculationAutomatic
End Sub
Try this code. This will clear the 0s from the used range in a sheet without changing the format.
Updated:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Replace what:=0, Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next ws
Use the setting in File > Options > Advanced and untick the "Show zeros ..." setting. This setting is on a per sheet basis, so, to automate it for the whole workbook, put this code into the ThisWorkbook module
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
ActiveWindow.DisplayZeros = False
End Sub
Now zeros will not display on any sheet.
I want to clear the contents if cell value is zero ((Either its in formula or value) The below code is working by selection of cells, but i want to do this for entire workbook please help me to change the code.
Sub DelZeros()
Dim c As Range
For Each c In Selection
If c.Value = 0 Then c.ClearContents
Next c
End Sub
Instead of Selection you could use ActiveSheet.UsedRange And if you need to do it for all sheets in a workbook you could do sth like that
Sub DelAllZeros()
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
Sub DelFormulaZeros()
Dim rg As Range, sngCell As Range
Dim sh As Worksheet
Dim result As Long
For Each sh In Worksheets
On Error Resume Next
Set rg = sh.Cells.SpecialCells(xlCellTypeFormulas, 1)
result = Err.Number
On Error GoTo 0
If result = 0 Then
For Each sngCell In rg
If sngCell.Value = 0 Then
sngCell.ClearContents
End If
Next
End If
Next
End Sub
Sub DelAllZeros()
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
ws.Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Set frange = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not frange Is Nothing Then
For Each c In frange
If c.Value = 0 Then
c.Formula = ClearContents
End If
Next c
End If
Set frange = Nothing
Next ws
Application.Calculation = xlCalculationAutomatic
End Sub