Flytning af farver mm.

Hmm, hvad handler det her om???
Har du ikke givet 200 point for det svar her? http://www.eksperten.dk/spm/833628

Husk, ifølge Ekspertens regler, er det ikke tilladt at udlove mere end 200 point for et spørgsmål.

Der er tale om en yderligere udbygning af ovennævnte:

Rem Version 3 - Ændringer for denne version er markeret med <---(3)

Dim sti, mappe2AntalArk, arkNavn, indsatFlag As Boolean
Private Sub CommandButton1_Click()
On Error GoTo fejl                      '<---(3)

    sti = ActiveWorkbook.Path          '
    If Right(sti, 1) <> "\" Then        '
        sti = sti + "\"                ' Egen tilføjelse
    End If                              '
   
    Application.ScreenUpdating = False
    Sheets("Ark1").Range("A1:H26").Copy '<------(3)
   
    arkNavn = Sheets("Ark1").Range("A15")
   
    Workbooks.Open Filename:=sti + "mappe2.xls"
    mappe2AntalArk = ActiveWorkbook.Sheets.Count
    indsatFlag = False
   
    For Each sh In Workbooks("mappe2.xls").Sheets
        sh.Activate
        If sh.Range("A10") = "" Then        'hvis A10 er tom så indsæt
            sh.Range("A1").Select          '<---(3)
            ActiveSheet.Paste              '<---(3)
           
            sh.Name = arkNavn              'tilpas arkNavn
            indsatFlag = True              'marker for indsat
            Exit For                        'afbryd
        End If
    Next
   
Rem Test om der blev indsat - hvis ikke opret nyt ark
    If indsatFlag = False Then
        opretNytArk arkNavn
    End If
   
    Afslut                                  '<---(3)
    Exit Sub                                '<---(3)
   
fejl:
    MsgBox ("ArkNavnet " + arkNavn + " er sandsynligvis anvendt i forvejen")
    Afslut
End Sub
Private Sub Afslut()
    Workbooks("mappe2.xls").Close savechanges:=True
    Application.CutCopyMode = False        '<---(3)
    Application.ScreenUpdating = True
End Sub
Private Sub opretNytArk(arkNavn)
On Error GoTo fejl
    With ActiveWorkbook
        .Sheets.Add After:=Worksheets(mappe2AntalArk)
        .Sheets(mappe2AntalArk + 1).Name = arkNavn
        .Sheets(mappe2AntalArk + 1).Activate
        ActiveSheet.Range("A1").Select      '<---(3)
        ActiveSheet.Paste                  '<---(3)
    End With
    Exit Sub
   
fejl:
    MsgBox ("ArkNavnet " + arkNavn + " er sandsynligvis anvendt i forvejen")
End Sub

Lige præcis. Takker meget for hjælpen:-)

Selv tak...