VBA hjælp

Anbringes under fane CaseList

Dim ræk As Integer, antalRækker As Integer
Public Sub arkivering()
    antalRækker = ActiveSheet.Range("K99999").End(xlUp).Row
    ræk = findRække(Sheets("CaseList"), "K1:K" & CStr(antalRækker), "x")
   
    If ræk > 0 Then
        svar = MsgBox("Er du sikker på at du vil arkivere række " & CStr(ræk), vbYesNo, "Arkivering")
        If svar = 6 Then
            Rows(ræk & ":" & ræk).Select
            Selection.Cut
            Sheets("Filed Cases").Select
            ActiveSheet.Rows("6:6").Select
            Selection.Insert Shift:=xlDown
       
            Sheets("CaseList").Select
            Selection.Delete Shift:=xlUp
        End If
    End If
End Sub
Private Function findRække(ark, område, id)
    With ark.Range(område)
        Set c = .Find(id, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findRække = c.Row
        Else
            findRække = 0
        End If
    End With
End Function

Hej supertekst
Koden virker perfekt, godt lavet. Dog får jeg nogle betinget formater med over i "FiledCases" som jeg gerne vil undgå, kan du rette det? Mange 1000 tak for hjælpen

Hej Boro23

Prøv at sende mig et eksempel på det du nævner

Selv tak :-)

Hej supertekst
Det må jeg desværre ikke. Måske du kan hjælpe mig, hvis jeg formulerer mig anderledes.

Det jeg mener er, at den række der skal arkiveres, skal indsættes "specielt værdier" i arket "FiledCases" så der ikke kommer nogen formater med over i arket "FiledCases".

Ok - er med  - vender tilbage lidt senere..

Rem Version 2
Dim ræk As Integer, antalRækker As Integer
Public Sub arkivering()
    antalRækker = ActiveSheet.Range("K99999").End(xlUp).Row
    ræk = findRække(Sheets("CaseList"), "K1:K" & CStr(antalRækker), "x")
   
    If ræk > 0 Then
        svar = MsgBox("Er du sikker på at du vil arkivere række " & CStr(ræk), vbYesNo, "Arkivering")
        If svar = 6 Then
Rem indsæt ny række 6 på Filed Cases
            Sheets("Filed Cases").Select
            ActiveSheet.Rows("6:6").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlNone
           
            Sheets("CaseList").Select
           
            Rows(ræk & ":" & ræk).Select
            Selection.Copy
            Sheets("Filed Cases").Select
           
            ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
               
            Sheets("CaseList").Select
            Selection.Cut
            Selection.Delete Shift:=xlUp
        End If
    End If
End Sub
Private Function findRække(ark, område, id)
    With ark.Range(område)
        Set c = .Find(id, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findRække = c.Row
        Else
            findRække = 0
        End If
    End With
End Function

1000 tak for hjælpen

Selv tak