CIO Tech Eksperten IT-JOB IT-Kurser Events Podcast Søg
Cookie ikon
Avatar billede gustavba Nybegynder
26. august 2008 - 12:49 Der er 22 kommentarer og
1 løsning

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
Avatar billede sager Nybegynder
26. august 2008 - 13:20 #1
Der er mange ting der kan gå galt der..
Kan der være sheets, hvor der er celler som er flettede?
Kan der være sheets, hvor der ikke findes et print_area?

Har du mulighed for at vise i hvilken linje det går galt (tryk Debug når den fejler)?
Avatar billede gustavba Nybegynder
26. august 2008 - 13:55 #2
Koden fejler p&#229; .select

For Each ws In ActiveWorkbook.Worksheets
With ws
  .Select

Der er helt sikkert celler som er flettede, men jeg copy/paster hele sheeted s&#229; det giver ikke problemer. Jeg har ogs&#229; on error resume next hvilket burde eliminere en del fejl.

Jeg har netop testet en workbook der virker men koden hvor jeg tilf&#248;jede et ekstra sheet med flettede celler uden print_area. Det gav ingen problemer.

Har ogs&#229; pr&#248;vet at slette alle ark p&#229; n&#230;r 3 i den workbook der ikke virker. Kontrollerede for print_area og andre uregelm&#230;ssigheder....intet resultat. Det virker stadig ikke...very strange.
Avatar billede sager Nybegynder
26. august 2008 - 21:48 #3
Er der et eller flere skjulte ark? Således at de ikke kan "select"'es?
Bemærk at arkene også kan være Very Hidden, hvorved man kun kan se at de er der fra VBE vinduet.
(Jeg gætter bare her - men håber vi sammen kan komme frem til noget)
Avatar billede kabbak Professor
26. august 2008 - 22:32 #4
data = Range("udskriftsområde")
    Cells.ClearContents
Range("Print_area") = data


Dette burde kunde koges ned:

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


til

Dim Data as Variant
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

                Data = Range("Print_area")
                Cells.ClearContents
                Range("Print_area") = Data
            End With
            Data = empty
            Cells("A1").Select

        Next ws
Avatar billede kabbak Professor
26. august 2008 - 22:46 #5
Ok ny kode, jeg kan ikke trimme den mere


Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    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
            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                Data = Range("Print_area")
                Cells.ClearContents
                Range("Print_area") = Data

            End If
        End With
        Range("A1").Select
    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede kabbak Professor
27. august 2008 - 08:28 #6
Den eneste grund til at du får en fejl, så vidt jeg kan se, er hvis du prøver at fjerne det sidste ark, som er i mappen, det kan man ikke og får fejl.

Jeg har nu kodet, så du får en advarsel, prøv at teste.


Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim Result As String
    'Promts the user to save the workbook with a new name before manipulating data.
    If Not ActiveWorkbook.Saved Then
        Result = Application.Dialogs(xlDialogSaveAs).Show
        If Result = False Then
            MsgBox ("You didn't save the workbook. This function will now exit!")
            Exit Sub
        End If
    End If
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                Data = .Range("Print_area")
                .Cells.ClearContents
                .Range("Print_area") = Data

            End If
            .Range("A1").Select
        End With

    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ActiveWorkbook.Sheets.Count = 1 And ws2.Tab.ColorIndex <> 37 Then
            MsgBox " Der er kun et ark tilbage, og det har ikke en blå fane"
            Exit Sub
        End If
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede gustavba Nybegynder
27. august 2008 - 08:49 #7
Det ser imponerende ud. Og det virker ogs&#229;....n&#230;sten
1.) Jeg f&#229;r en fejl hvis der ikke er defineret et print area.
2.) Jeg f&#229;r kun slettet data udenfor Print_area p&#229; det sheet jeg aktivierer koden fra.
Avatar billede kabbak Professor
27. august 2008 - 09:03 #8
1. det gør jeg også, der skal altid være angivet et udskriftområde, på de ark med blå fane.

2. virker overalt her.

har du brugt den sidste kode ??, den her

Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim Result As String
    'Promts the user to save the workbook with a new name before manipulating data.
    If Not ActiveWorkbook.Saved Then
        Result = Application.Dialogs(xlDialogSaveAs).Show
        If Result = False Then
            MsgBox ("You didn't save the workbook. This function will now exit!")
            Exit Sub
        End If
    End If
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                Data = .Range("Print_area")
                .Cells.ClearContents
                .Range("Print_area") = Data

            End If
          ' .Range("A1").Activate
        End With

    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ActiveWorkbook.Sheets.Count = 1 And ws2.Tab.ColorIndex <> 37 Then
            MsgBox " Der er kun et ark tilbage, og det har ikke en blå fane"
            Exit Sub
        End If
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede kabbak Professor
27. august 2008 - 09:07 #9
Hvad skal den gøre, hvis der ikke er noget printarea, skal den tage hele arket og lave til værdier ?
Avatar billede kabbak Professor
27. august 2008 - 09:12 #10
så skulle fejl1 også være luset ud

Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim Result As String
    'Promts the user to save the workbook with a new name before manipulating data.
    If Not ActiveWorkbook.Saved Then
        Result = Application.Dialogs(xlDialogSaveAs).Show
        If Result = False Then
            MsgBox ("You didn't save the workbook. This function will now exit!")
            Exit Sub
        End If
    End If
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                If .PageSetup.PrintArea <> "" Then    ' er der angivet et print_area
                    Data = .Range("Print_area")
                    .Cells.ClearContents
                    .Range("Print_area") = Data
                Else    '                                hvis ikke tages hele området
                    Data = .UsedRange
                    .UsedRange = Data
                End If
            End If

        End With

    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ActiveWorkbook.Sheets.Count = 1 And ws2.Tab.ColorIndex <> 37 Then
            MsgBox " Der er kun et ark tilbage, og det har ikke en blå fane"
            Exit Sub
        End If
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede gustavba Nybegynder
27. august 2008 - 10:44 #11
Sidste kode virker fortrinligt. Det er helt fint at den bare laver v&#230;rdier ud p&#229; ark uden print_area.

Der er dog noget af den oprindelige kodes funktionalitet som er g&#229;et tabt.
Jeg ville frygteligt gerne ende op med p&#229; hvert sheet at f&#229; print_area lokaliseret med udgangspunkt i A1.
Den oprindelige kode slettede r&#230;kker over og kolonner til venstre for Print_area.
Avatar billede kabbak Professor
27. august 2008 - 11:16 #12
denne her skulle da tømme celler der ligger udenfor, men du vil have rækker og kolonne slettet fysisk, i stedet.

Skal formatet i Print_area beholdes
Avatar billede gustavba Nybegynder
27. august 2008 - 11:57 #13
ja og ja

Jeg &#248;nsker at ende op med en workbook hvor formler i Printarea og data udenfor printarea er slettet. Formatet p&#229; printarea og sidehoved sidefod etc. skal bibeholdes og print area skal have udgangspunkt i A1.
P&#229; den m&#229;de kan jeg have en workbook hvor jeg har alle mulige avancerede formler og beregninger og kildedata liggende, men alligevel let lave en workbook (ved at definere et print_area), som er til at skrive ud og eventuelt arbejde videre p&#229; for 3. mand.

I dette helt konkrete tilf&#230;lde er det for let at kunne gemme udvaglte data fra en &#248;konomisk rapportering i en ny fil. Modtager kan let udskrive data, og da han modtager en exel fil, kan han selv lave yderligere diagrammer etc. Han f&#229;r dog kun v&#230;rdier i regnearket, da jeg ikke &#248;nsker, at han skal snage rundt i mine formler, eller m&#229;ske komme til at slette nogle formler s&#229; resten af indholdet g&#229;r fl&#248;jten.
Avatar billede kabbak Professor
27. august 2008 - 12:20 #14
Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim Result As String
    'Promts the user to save the workbook with a new name before manipulating data.
    If Not ActiveWorkbook.Saved Then
        Result = Application.Dialogs(xlDialogSaveAs).Show
        If Result = False Then
            MsgBox ("You didn't save the workbook. This function will now exit!")
            Exit Sub
        End If
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Worksheets.Add
    ActiveSheet.Name = "9999"    ' midlertidig ark
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                If .PageSetup.PrintArea <> "" Then    ' er der angivet et print_area
                    .Range("Print_area").Copy
                    Sheets("9999").Range("A1").Range("A1").PasteSpecial xlPasteFormats
                    Sheets("9999").Range("A1").Range("A1").PasteSpecial xlPasteValues
                    .Cells.Delete Shift:=xlUp
                    Sheets("9999").Range("A1").CurrentRegion.Copy .Range("A1")
                    Sheets("9999").Cells.Delete Shift:=xlUp
                Else    '                                hvis ikke tages hele området
                    Data = .UsedRange
                    .UsedRange = Data
                End If
            End If

        End With

    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ActiveWorkbook.Sheets.Count = 1 And ws2.Tab.ColorIndex <> 37 Then
            MsgBox " Der er kun et ark tilbage, og det har ikke en blå fane"
            Exit Sub
        End If
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede gustavba Nybegynder
28. august 2008 - 10:40 #15
Denne kode giver mig faktisk den oprindelige fejl :-(

Jeg har mulighed for at sende workbook&#180;en til dig s&#229; du kan se fejlen hvis du har lyst.

Microsoft skriver dette som m&#229;ske er det der fremkalder fejlen:

In Microsoft Excel, you run a macro that copies worksheets and then places the worksheets into the same workbook from which they originated. When you do this, you may receive an error message that resembles one of the following error messages:

Run-time error '1004':
Application-defined or object-defined error


M&#229;ske er l&#248;sningen at kopiere de udvalgte sheets over i en ny workbook, men i s&#229; fald skal det jo g&#248;res stepvis (formater, v&#230;rdier, sideops&#230;tning, header/footer), for ikke at havne i samme problem?
Avatar billede kabbak Professor
28. august 2008 - 11:09 #16
kabbak snabela tiscali dot dk

jeg kan først teste i aften
Avatar billede kabbak Professor
28. august 2008 - 17:50 #17
Den rettede kode

Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim Result As String
    'Promts the user to save the workbook with a new name before manipulating data.
    Application.Dialogs(xlDialogSaveAs).Show
    If Not ActiveWorkbook.Saved Then
        Result = Application.Dialogs(xlDialogSaveAs).Show
        If Result = False Then
            MsgBox ("You didn't save the workbook. This function will now exit!")
            Exit Sub
        End If
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Worksheets.Add
    ActiveSheet.Name = "9999"    ' midlertidig ark
    For Each ws In ActiveWorkbook.Worksheets
        With ws
       
            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                If .PageSetup.PrintArea <> "" Then    ' er der angivet et print_area
                    .Range("Print_area").Copy
                    Sheets("9999").Range("A1").PasteSpecial xlPasteValues
                    Sheets("9999").Range("A1").PasteSpecial xlPasteFormats
                    .Cells.Delete Shift:=xlUp
                    Sheets("9999").UsedRange.Copy .Range("A1")
                    Sheets("9999").Cells.Delete Shift:=xlUp
                Else    '                                hvis ikke tages hele området
                    Data = .UsedRange
                    .UsedRange = Data
                End If
            End If

        End With

    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ActiveWorkbook.Sheets.Count = 1 And ws2.Tab.ColorIndex <> 37 Then
            MsgBox " Der er kun et ark tilbage, og det har ikke en blå fane"
            Exit Sub
        End If
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede gustavba Nybegynder
01. september 2008 - 09:41 #18
En sidste ting. Kolonnebredder kommer ikke med over i de nye sheets. Jeg har fors&#248;gt mig med at inds&#230;tte
Sheets("9999").Range("A1").PasteSpecial xlPasteColumnWidths
men uden den store success. Er det noget du kan sige hvordan lader sig g&#248;re?
Avatar billede kabbak Professor
01. september 2008 - 10:35 #19
Min fejl, glemte det i koden, her er det med

Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim Result As String
    'Promts the user to save the workbook with a new name before manipulating data.
    Application.Dialogs(xlDialogSaveAs).Show
    If Not ActiveWorkbook.Saved Then
        Result = Application.Dialogs(xlDialogSaveAs).Show
        If Result = False Then
            MsgBox ("You didn't save the workbook. This function will now exit!")
            Exit Sub
        End If
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Worksheets.Add
    ActiveSheet.Name = "9999"    ' midlertidig ark
    For Each ws In ActiveWorkbook.Worksheets
        With ws
     
            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                If .PageSetup.PrintArea <> "" Then    ' er der angivet et print_area
                    .Range("Print_area").Copy
                    Sheets("9999").Range("A1").PasteSpecial xlPasteValues
                    Sheets("9999").Range("A1").PasteSpecial xlPasteFormats
                    .Cells.Delete Shift:=xlUp
                    Sheets("9999").UsedRange.Copy .Range("A1")
                    .Range("A1").PasteSpecial xlPasteFormats
                    Sheets("9999").Cells.Delete Shift:=xlUp
                Else    '                                hvis ikke tages hele området
                    Data = .UsedRange
                    .UsedRange = Data
                End If
            End If

        End With

    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ActiveWorkbook.Sheets.Count = 1 And ws2.Tab.ColorIndex <> 37 Then
            MsgBox " Der er kun et ark tilbage, og det har ikke en blå fane"
            Exit Sub
        End If
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede gustavba Nybegynder
01. september 2008 - 13:22 #20
Jeg g&#229;r ud fra at du mener at linjen
.Range("A1").PasteSpecial xlPasteFormats
skal v&#230;re
.Range("A1").PasteSpecial xlPasteColumnWidths

Uanset hvilken linje jeg benytter f&#229;r jeg - PasteSpecial method Range class failed-

:-(
Avatar billede kabbak Professor
01. september 2008 - 18:43 #21
Option Explicit

Sub Get_wb_ready_for_distribution()
    Dim Data As Variant
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim Result As String
    'Promts the user to save the workbook with a new name before manipulating data.
    Application.Dialogs(xlDialogSaveAs).Show
    If Not ActiveWorkbook.Saved Then
        Result = Application.Dialogs(xlDialogSaveAs).Show
        If Result = False Then
            MsgBox ("You didn't save the workbook. This function will now exit!")
            Exit Sub
        End If
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Worksheets.Add
    ActiveSheet.Name = "9999"    ' midlertidig ark
    ActiveSheet.Tab.ColorIndex = xlNone
    For Each ws In ActiveWorkbook.Worksheets
        With ws

            If .Tab.ColorIndex = 37 Then
                If .ProtectContents = True Then
                    .Unprotect Password:=""
                End If
                If .PageSetup.PrintArea <> "" Then    ' er der angivet et print_area
                    .Range("Print_area").Copy
                    Sheets("9999").Range("A1").PasteSpecial xlPasteValues
                    Sheets("9999").Range("A1").PasteSpecial Paste:=xlPasteFormats
                    Sheets("9999").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                    .Cells.Delete Shift:=xlUp
                    Sheets("9999").UsedRange.Copy
                    .Range("A1").PasteSpecial xlPasteValues
                    .Range("A1").PasteSpecial Paste:=xlPasteFormats
                    .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                    Sheets("9999").Cells.Delete Shift:=xlUp
                Else    '                                hvis ikke tages hele området
                    Data = .UsedRange
                    .UsedRange = Data
                End If
            End If

        End With

    Next ws

    For Each ws2 In ActiveWorkbook.Worksheets
        If ActiveWorkbook.Sheets.Count = 1 And ws2.Tab.ColorIndex <> 37 Then
            MsgBox " Der er kun et ark tilbage, og det har ikke en blå fane"
            Exit Sub
        End If
        If ws2.Tab.ColorIndex <> 37 Then ws2.Delete
    Next ws2

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Avatar billede kabbak Professor
04. september 2008 - 22:19 #22
hvordan går det ??
Avatar billede gustavba Nybegynder
05. september 2008 - 08:31 #23
Det går faktisk fint. Takker mange gange for hjælpen. troede egentlig jeg havde lukket denne, men det har jeg vist nu :-)
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Excel kurser
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.
Se alle Excel kurser

Flere spørgsmål fra Excel kategorien

Titel Indlæg Oprettet Seneste aktivitet
Identificér og hent del af tekststreng Af TheLibrarian i Excel 1 I går 16:49 I går 21:00
Ændre nuller til ovenstående tekst Af boro23 i Excel 4 20/11/202410:44 20/11/202412:08
HVIS med datoer Af HHA i Excel 6 20/11/202408:31 20/11/202412:51
Numerisk liste Af AND i Excel 8 19/11/202414:05 19/11/202423:31
Ændre nuller til ovenstående tal Af boro23 i Excel 3 19/11/202409:39 19/11/202411:51
Se alle spørgsmål i kategorien Opret spørgsmål

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Opret Log ind

Du kan også logge ind via nedenstående tjenester



Alle kategorier på Eksperten
Seneste spørgsmål Seneste aktivitet
I går 20:49 pop up black friday Af Malm i Virus
I går 18:31 Hvor finder jeg en netværksdriver? Af jcr18 i Wifi
I går 16:49 Identificér og hent del af tekststreng Af TheLibrarian i Excel
I går 16:30 Smart vægt til fitness tracking Af Henrik i Fitness & Smartwatches
I går 08:08 touchpad virker ikke Af Malm i PC
White papers
Flere white papers »


Premium
Teaser billede
Vil købe tele-løsninger til det offentlige for 370 millioner kroner
Læs mere »
Efterspørgslen på AI-regnekraft er enorm - og det smitter af på priserne: "Vi kan sælge næsten alt, hvad vi får ind"
Nyt værtøj fra Microsoft: Snart kan du reparere nedbrudte Windows-enheder på distancen
Politiet skriver kontrakt på 75 millioner kroner med dansk it-firma: Medarbejdere skal flytte ind hos politiet
Se alle »
Computerworld
Teaser billede
Microsofts nye pc er ekstrem billig – men kan blive ekstrem sikker og fleksibel
Læs mere »
Test: Audi Q6 er en super fed SUV - men gør dig selv en tjeneste og kast flere penge efter den
Test: Prøv kun disse B&O-hovedtelefoner, hvis du har råd
Kæmpe datalæk på hospital: 750.000 patienters fortrolige data lækket
Se alle »
CIO
Teaser billede
Konsulenthus vil rulle Microsoft 365 Copilot ud til 200.000 ansatte
Læs mere »
Kæmpe-opgave for Danske Bank har banet vej for fuldautomatiseret migrering til cloud: Nu udbredes metoden i hele AWS
Stor sag mod Microsoft kan være på vej: Beskyldes for at låse Azure-kunder fast med ulovlige metoder
Microsofts store årlige event: De tre vigtigste nøglebudskaber fra Satya Nadella om Microsofts fremtid
Se alle »
Job & Karriere
Teaser billede
Microsoft klar med ny direktion for den danske forretning: Her er de nye direktører
Læs mere »
Tre Norlys-topchefer fratræder med omgående virkning: Internet-forretningen er udfordret - vil have mere fart i integrationen af Telia Danmark
Efter skelsættende møde med sportscoach: Stor dansk it-arbejdsplads indfører fredags-fri og isbade i arbejdstiden
Linus Torvalds giver russiske Linux-udviklere sparket: Vil ikke have noget med dem at gøre
Se alle »
White paper
Teaser billede
Er din cybersikkerhed klar til AI-revolutionen?
Læs mere »
Vær proaktiv og prioritér IT-sikkerheden – før det er for sent
Sæt turbo på din cloudperformance og minimér risikoen for DDoS-angreb
MDR: Transparent sikkerhed og overvågning i realtid
Se alle »

Events
Flere events »
White papers
Flere white papers »
IT-Kurser
Se alle vores it-kurser »