Run-time error '1004' Application-defined or object defined error
Her er en svær en som jeg virkelig gerne kunne tænke mig lidt hjælp til.Jeg har en macro som jeg af og til assigner til en knap i excel. Koden looper igennem alle sheets gemmer og copy-paster values only på hver sheet. Herefter sletter koden alle celler med indhold udenfor printarea. Alt dette sker kun på blå sheets. Alle andre sheets deletes.
Formålet er at fremstille en workbook med udvalgte sheets som er renset for formler og således kan sendes ud til læseren (vi taler on en økonomiske nøgletal).
Denne macro virker fint i et par forskellige workbooks. Den virker også fint når jeg opretter et helt tomt regneark for at teste koden, men i et tilfælde hvor jeg forsøger at benytte koden i et regneark med forskellige data i 17 sheets får jeg fejlen:
Run-time error '1004' Application-defined or object defined error
Jeg kan bare ikke finde ud af hvad det er der går galt.
Måske er der lidt hjælp her, men 10-øren falder ikke for mig.
http://support.microsoft.com/kb/210684
Please - Everyone?
Sub Get_wb_ready_for_distribution()
Dim x
Dim ws As Worksheet
Dim t
Dim lastRK
Dim lastKOL
Dim ws2 As Worksheet
'Promts the user to save the workbook with a new name before manipulating data.
Application.Dialogs(xlDialogSaveAs).Show
If Not ThisWorkbook.Saved Then Result = MsgBox("You didn't save the workbook. This function will now exit!")
If Result = vbOK Then
Exit Sub
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
With ws
.Select
If ActiveSheet.Tab.ColorIndex = 37 Then
If ActiveSheet.ProtectContents = True Then
ActiveSheet.Unprotect Password:=""
End If
Range("Print_area").Select
Selection.Copy
'Copies sheet and pastes values only
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Removes columns to the left of Print_area and rows above
On Error Resume Next
Rows("1:" & Range("print_area").Row - 1).EntireRow.Delete
If Range("print_area").Column - 1 >= 1 Then
For t = Range("print_area").Column - 1 To 1 Step -1
Columns(t).EntireColumn.Delete
Next
End If
lastRK = Range("A1").SpecialCells(xlLastCell).Row
lastKOL = Range("A1").SpecialCells(xlLastCell).Column
Rows(Range("print_area").Rows.Count + 1 & ":" & lastRK).EntireRow.Delete
Range("print_area").Offset(0, Range("print_area").Columns.Count).Resize(1, lastKOL).EntireColumn.Delete
Else:
End If
On Error Resume Next
End With
Cells("A1").Select
Next ws
For Each ws2 In ActiveWorkbook.Worksheets
With ws2
.Select
If ActiveSheet.Tab.ColorIndex <> 37 Then
ActiveSheet.Delete
End If
On Error Resume Next
End With
Next ws2
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub