Solved: KB entry "Reduce Excel File Size "give run time error 1004

[rrosa1]

hi
i was trying to reduce the file size by using KB entries "Reduce Excel File Size" By DRJ

it give me the Run time error 1004
Delete method of Range class failed
can some one help
thanks
P.S.
code stuck at

.Range(Cells(1, LastCol + 1).Address & ":IV65536").Delete
.Range(Cells(LastRow + 1, 1).Address & ":IV65536").Delete
i am using 2003 excel

[GTO]

Could you put a link in to the kb entry? I am nearly certain that I have used the code w/no problem. I do see that Cells is not qualified, but w/o seeing the remaining code, it's hard to tell...

[rrosa1]

yes sir
thanks for loking

http://www.vbaexpress.com/kb/getarticle.php?kb_id=83

[GTO]

In using the example file, I could not replicate the error. Can you obfuscate any sensitive data and attach an example wb that errors?

Off to the rack for me, but if not already answered, I'll try and look later.

Have a great day,

Mark

[rrosa1]

hi GTO
here is wb

[Bob Phillips]

Sub ExcelDiet()

Dim j As Long
Dim k As Long
Dim LastRow As Long
Dim LastCol As Long
Dim ColFormula As Range
Dim RowFormula As Range
Dim ColValue As Range
Dim RowValue As Range
Dim Shp As Shape
Dim ws As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

On Error Resume Next

For Each ws In Worksheets
With ws

If ws.Name <> "Run Data" Then

'Find the last used cell with a formula and value
'Search by Columns and Rows
On Error Resume Next
Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
On Error GoTo 0

'Determine the last column
If ColFormula Is Nothing Then
LastCol = 0
Else
LastCol = ColFormula.Column
End If
If Not ColValue Is Nothing Then
LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
End If

'Determine the last row
If RowFormula Is Nothing Then
LastRow = 0
Else
LastRow = RowFormula.Row
End If
If Not RowValue Is Nothing Then
LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
End If

'Determine if any shapes are beyond the last row and last column
For Each Shp In .Shapes
j = 0
k = 0
On Error Resume Next
j = Shp.TopLeftCell.Row
k = Shp.TopLeftCell.Column
On Error GoTo 0
If j > 0 And k > 0 Then
Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
j = j + 1
Loop
If j > LastRow Then
LastRow = j
End If
Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
k = k + 1
Loop
If k > LastCol Then
LastCol = k
End If
End If
Next

.Unprotect
.Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
.Range(.Cells(LastRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
.Protect
End If
End With
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[rrosa1]

hi Xld
u r the "Distinguished Lord of VBAX"
u always save my ass thank you very much
sorry to ask diff question in same thread but
i have search every possible place for replacingthe numerical value of cells in ws with only 2 decimal point. since my ws value comes from calcu.
and copy/paste
ie. 0.235684 etc
but i am interested only for 2 digit
As 0.23 if u can guide me it highly appreciatedthanks again

[Bob Phillips]

Something like this?



For Each cell In Activesheet.UsedRange

cell.Value = Application.RoundDown(cell.Value, 2)
Next cell

[rrosa1]

thanks xld
but it change the txt cell also so how can restrict the code to change only numerical cell only

sorry but i am copy /past guy so pl bear with me
thanks

[Bob Phillips]

Sorry, I should have thought of that



For Each cell In ActiveSheet.UsedRange

If IsNumeric(cell.Value) Then cell.Value = Application.RoundDown(cell.Value, 2)
Next cell

[rrosa1]

hi
thanks but
can we also check the empty cell which don't have any value then don't change that cell and go to next numerical cell and Rounddown that cell only?

since right now the code do rounddown the empty cell and put 0 in it
thanks buddy


0 0 0 <-------- empty row but now have 0 in it
2.42 3.45 4.56 <------- on numerical data cell it work

[Blade Hunter]

Try this, it is an alternative version I wrote a while ago (I am waiting on it to be approved in the KB).

It will copy pictures also but charts will be lost, I will be adding that feature later.


Sub LipoSuction2()
'Written by Daniel Donoghue 18/8/2009
'The purpose of this code is to offer an alternative to the original Liposuction code written by JBeaucaire for the MrExcel forums www.mrexcel.com (http://www.mrexcel.com)
Dim WS As Worksheet
Dim CurrentSheet As String
Dim OldSheet As String
Dim Col As Long
Dim R As Long
Dim BottomrRow As Long
Dim EndCol As Long
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Dim Pic As Object
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
For Each WS In Worksheets
WS.Activate
'Put the sheets in a variable to make it easy to go back and forth
CurrentSheet = WS.Name
'Rename the sheet to its name with TRMFAT at the end
OldSheet = CurrentSheet & "TRMFAT"
WS.Name = OldSheet
'Add a new sheet and call it the original sheets name
Sheets.Add
ActiveSheet.Name = CurrentSheet
Sheets(OldSheet).Activate
'Find the bottom cell of data on each column and find the further row
For Col = 1 To Columns.Count 'Find the REAL bottom row
If Cells(Rows.Count, Col).End(xlUp).Row > BottomRow Then
BottomRow = Cells(Rows.Count, Col).End(xlUp).Row
End If
Next
'Find the end cell of data on each row that has data and find the furthest one
For R = 1 To BottomRow 'Find the REAL most right column
If Cells(R, Columns.Count).End(xlToLeft).Column > EndCol Then
EndCol = Cells(R, Columns.Count).End(xlToLeft).Column
End If
Next
'Copy the REAL set of data
Range(Cells(1, 1), Cells(BottomRow, EndCol)).Copy
Sheets(CurrentSheet).Activate
'Paste everything
Range("A1").PasteSpecial xlPasteAll
'Paste Column Widths
Range("A1").PasteSpecial xlPasteColumnWidths
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Sheets(OldSheet).Activate
For Each Pic In ActiveSheet.Pictures
Pic.Copy
Sheets(CurrentSheet).Paste
Sheets(CurrentSheet).Pictures(Pic.Index).Top = Pic.Top
Sheets(CurrentSheet).Pictures(Pic.Index).Left = Pic.Left
Next
Sheets(CurrentSheet).Activate
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
'Reset the variable for the next sheet
BottomRow = 0
EndCol = 0
Next
'Excel will automatically replace the sheet references for you on your formulas, the below part puts them back
'This is done with a simple reaplce, replacing TRMFAT with nothing
For Each WS In Worksheets
WS.Activate
Cells.Replace "TRMFAT", ""
Next
'Poll through the sheets and delete the original bloated sheets
For Each WS In Worksheets
If Not Len(Replace(WS.Name, "TRMFAT", "")) = Len(WS.Name) Then
Application.DisplayAlerts = False
WS.Delete
Application.DisplayAlerts = True
End If
Next
End Sub

[rrosa1]

hi blade hunter
for ur help but XLD fix my problem
but now i am stuck in anther problem as in post #11

[Blade Hunter]

hi blade hunter
for ur help but XLD fix my problem
but now i am stuck in anther problem as in post #11

For Each cell In ActiveSheet.UsedRange

If isnumeric(cell) Then cell.Value = Application.RoundDown(cell.Value, 2)
Next cell

[rrosa1]

hi blade hunter
but that code also change the empty cell with 0.00
also i attached the ws image u can find in the post #11

[Bob Phillips]

Okay, another shot



Dim cell As Range
For Each cell In ActiveSheet.UsedRange

If Not cell.Value = "" Then

If IsNumeric(cell.Value) Then

cell.Value = Application.RoundDown(cell.Value, 2)
End If
End If
Next cell

[Blade Hunter]

CCan you check the cell number formatting and report back please?

[rrosa1]

thanks XLD
u rock man
i don't want to sound like doing buttering but u the legend
thanks for all your help