Ändring af VBA kode sä den passer til "gl. Excel"97-03

Umiddelbart er der 2 steder jeg kan se at dette kan gå galt og begge er i private sub FindProjekter. Der kan sagtens være flere steder, men du må fortælle hvor det kikser (debug og se hvilken linie er markeret med gult i koden.
Her er en rettet version. Test og vend tilbage.

Private Sub FindProjekter()

    Application.ScreenUpdating = False
    Dim i As Long, j As Long, k As Long, lEnd As Long
    Dim sNames() As String
    Sheets("Projektweise").Select
    i = Range("A5000").End(xlUp).Row + 5
    Rows("3:" & CStr(i)).Select
    Selection.Delete Shift:=xlUp
    Sheets("Bank 09").Select
    lEnd = Range("G3").End(xlDown).Row
    ReDim sNames(0)
    For i = 3 To lEnd
        For j = 1 To 7
            Sheets("Projektweise").Cells(i, j).Value = Sheets("Bank 09").Cells(i, j).Value
        Next j
    Next i
    Sheets("Projektweise").Select
    Range("A3:Q" & CStr(lEnd)).Select
    'som i xl2003
    Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Key2:=Range("A3"), _
        Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortTextAsNumbers
   
   
'    ActiveWorkbook.Worksheets("Projektweise").Sort.SortFields.Clear
'    ActiveWorkbook.Worksheets("Projektweise").Sort.SortFields.Add Key:=Range( _
'        "G3:G" & CStr(lEnd)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
'        xlSortNormal
'    ActiveWorkbook.Worksheets("Projektweise").Sort.SortFields.Add Key:=Range( _
'        "A3:A" & CStr(lEnd)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
'        xlSortNormal
'    With ActiveWorkbook.Worksheets("Projektweise").Sort
'        .SetRange Range("A3:Q" & CStr(lEnd))
'        .Header = xlGuess
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With


    ReDim sNames(0)
    For i = 3 To lEnd
        For j = 0 To UBound(sNames)
            If sNames(j) = Sheets("Projektweise").Cells(i, 7).Value Then Exit For
        Next j
        If j = UBound(sNames) + 1 Then
            ReDim Preserve sNames(k)
            sNames(k) = Sheets("Projektweise").Cells(i, 7).Value
            k = k + 1
        End If
    Next i
    Dim rFound As Range
    Dim lPlace As Long, OldPlace As Long
    OldPlace = 3
    For i = 1 To UBound(sNames)
        Range("G3:G" & CStr(lEnd + (UBound(sNames) * 3))).Select
        Set rFound = Selection.Find(What:=sNames(i), After:=ActiveCell, LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        lPlace = rFound.Row
        Rows(CStr(lPlace) & ":" & CStr(lPlace)).Select
        Selection.Insert Shift:=xlDown  ', CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown  ', CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown  ', CopyOrigin:=xlFormatFromLeftOrAbove
        Rows(CStr(lPlace) & ":" & CStr(lPlace)).Interior.Color = RGB(0, 153, 0)
        Cells(lPlace, 1).Formula = "SUMMEN"
        Cells(lPlace, 2).Formula = "=SUM(B" & CStr(OldPlace) & ":B" & CStr(lPlace - 1) & ")"
        Cells(lPlace, 3).Formula = "=SUM(C" & CStr(OldPlace) & ":C" & CStr(lPlace - 1) & ")"
        Cells(lPlace + 1, 1).Formula = "DIFF"
        Cells(lPlace + 1, 3).Formula = "=B" & CStr(lPlace) & "+C" & CStr(lPlace)
        OldPlace = lPlace + 3
    Next i
    lPlace = Range("G" & CStr(OldPlace)).End(xlDown).Row + 1
    Rows(CStr(lPlace) & ":" & CStr(lPlace)).Interior.Color = RGB(0, 153, 0)
    Cells(lPlace, 1).Formula = "SUMMEN"
    Cells(lPlace, 2).Formula = "=SUM(B" & CStr(OldPlace) & ":B" & CStr(lPlace - 1) & ")"
    Cells(lPlace, 3).Formula = "=SUM(C" & CStr(OldPlace) & ":C" & CStr(lPlace - 1) & ")"
    Cells(lPlace + 1, 1).Formula = "DIFF"
    Cells(lPlace + 1, 3).Formula = "=B" & CStr(lPlace) & "+C" & CStr(lPlace)
    Cells(1, 1).Select
    Sheets(1).Select
    Cells(1, 1).Select
    Application.ScreenUpdating = True

End Sub

Ok der er en fejl i förste linje af det du har sendt:
Compile error: Syntax error. Private Sub FindProjekter()

Og sidste gang sagde den at der var denne fejl;  Compile error: Variable not defined og  markerer den xlSortOnValues i koden. Det var altsä för jeg fik din kode ind.

Det den markerede den her gang var egentlig Application.Screenupdating = false

Har du fjernet den gamle sub FindProjekter ?

Ja den gamle sub FindProjkter skulle vaere fjerner. Lige nu ser koden sädan ud:

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Call OpdaterArk
    Call FindProjekter

End Sub

Private Sub OpdaterArk()

    Application.ScreenUpdating = False
    Dim i As Long, j As Long, k As Long
    Dim sNames(3) As String
    Dim lPosts(3) As Long
    For i = 2 To 5
        sNames(i - 2) = Sheets(i).Name
    Next i
    Sheets(1).Select
    j = Range("F3").End(xlDown).Row
    For i = 3 To j
        For k = 0 To 3
            If LCase(Cells(i, 6)) = LCase(sNames(k)) Then
                lPosts(k) = lPosts(k) + 1
                Exit For
            End If
        Next k
    Next i
    Dim Data2() As Variant
    ReDim Data2(lPosts(0), 5)
    Dim Data3() As Variant
    ReDim Data3(lPosts(1), 5)
    Dim Data4() As Variant
    ReDim Data4(lPosts(2), 5)
    Dim Data5() As Variant
    ReDim Data5(lPosts(3), 5)
    Dim Count(3) As Long
    For i = 3 To j
        Select Case LCase(Cells(i, 6))
            Case LCase(sNames(0))
                Count(0) = Count(0) + 1
                For k = 0 To 4
                    Data2(Count(0), k) = Cells(i, k + 1).Value
                Next k
                Data2(Count(0), 5) = Cells(i, 7).Value
            Case LCase(sNames(1))
                Count(1) = Count(1) + 1
                For k = 0 To 4
                    Data3(Count(1), k) = Cells(i, k + 1).Value
                Next k
                Data3(Count(1), 5) = Cells(i, 7).Value
            Case LCase(sNames(2))
                Count(2) = Count(2) + 1
                For k = 0 To 4
                    Data4(Count(2), k) = Cells(i, k + 1).Value
                Next k
                Data4(Count(2), 5) = Cells(i, 7).Value
            Case LCase(sNames(3))
                Count(3) = Count(3) + 1
                For k = 0 To 4
                    Data5(Count(3), k) = Cells(i, k + 1).Value
                Next k
                Data5(Count(3), 5) = Cells(i, 7).Value
        End Select
    Next i
    Sheets(sNames(0)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data2, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data2(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(0)
        Cells(i + 2, 7).Value = Data2(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(1)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data3, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data3(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(1)
        Cells(i + 2, 7).Value = Data3(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(2)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data4, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data4(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(2)
        Cells(i + 2, 7).Value = Data4(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(3)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data5, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data5(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(3)
        Cells(i + 2, 7).Value = Data5(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(1).Select
    Cells(1, 1).Select
    Application.ScreenUpdating = True

End Sub

Private Sub FindProjekter()

    Application.ScreenUpdating = False
    Dim i As Long, j As Long, k As Long, lEnd As Long
    Dim sNames() As String
    Sheets("Projektweise").Select
    i = Range("A5000").End(xlUp).Row + 5
    Rows("3:" & CStr(i)).Select
    Selection.Delete Shift:=xlUp
    Sheets("Bank 09").Select
    lEnd = Range("G3").End(xlDown).Row
    ReDim sNames(0)
    For i = 3 To lEnd
        For j = 1 To 7
            Sheets("Projektweise").Cells(i, j).Value = Sheets("Bank 09").Cells(i, j).Value
        Next j
    Next i
    Sheets("Projektweise").Select
    Range("A3:Q" & CStr(lEnd)).Select
    'som i xl2003
    Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Key2:=Range("A3"), _
        Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortTextAsNumbers
   
   
'    ActiveWorkbook.Worksheets("Projektweise").Sort.SortFields.Clear
'    ActiveWorkbook.Worksheets("Projektweise").Sort.SortFields.Add Key:=Range( _
'        "G3:G" & CStr(lEnd)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
'        xlSortNormal
'    ActiveWorkbook.Worksheets("Projektweise").Sort.SortFields.Add Key:=Range( _
'        "A3:A" & CStr(lEnd)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
'        xlSortNormal
'    With ActiveWorkbook.Worksheets("Projektweise").Sort
'        .SetRange Range("A3:Q" & CStr(lEnd))
'        .Header = xlGuess
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With


    ReDim sNames(0)
    For i = 3 To lEnd
        For j = 0 To UBound(sNames)
            If sNames(j) = Sheets("Projektweise").Cells(i, 7).Value Then Exit For
        Next j
        If j = UBound(sNames) + 1 Then
            ReDim Preserve sNames(k)
            sNames(k) = Sheets("Projektweise").Cells(i, 7).Value
            k = k + 1
        End If
    Next i
    Dim rFound As Range
    Dim lPlace As Long, OldPlace As Long
    OldPlace = 3
    For i = 1 To UBound(sNames)
        Range("G3:G" & CStr(lEnd + (UBound(sNames) * 3))).Select
        Set rFound = Selection.Find(What:=sNames(i), After:=ActiveCell, LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        lPlace = rFound.Row
        Rows(CStr(lPlace) & ":" & CStr(lPlace)).Select
        Selection.Insert Shift:=xlDown  ', CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown  ', CopyOrigin:=xlFormatFromLeftOrAbove
        Selection.Insert Shift:=xlDown  ', CopyOrigin:=xlFormatFromLeftOrAbove
        Rows(CStr(lPlace) & ":" & CStr(lPlace)).Interior.Color = RGB(0, 153, 0)
        Cells(lPlace, 1).Formula = "SUMMEN"
        Cells(lPlace, 2).Formula = "=SUM(B" & CStr(OldPlace) & ":B" & CStr(lPlace - 1) & ")"
        Cells(lPlace, 3).Formula = "=SUM(C" & CStr(OldPlace) & ":C" & CStr(lPlace - 1) & ")"
        Cells(lPlace + 1, 1).Formula = "DIFF"
        Cells(lPlace + 1, 3).Formula = "=B" & CStr(lPlace) & "+C" & CStr(lPlace)
        OldPlace = lPlace + 3
    Next i
    lPlace = Range("G" & CStr(OldPlace)).End(xlDown).Row + 1
    Rows(CStr(lPlace) & ":" & CStr(lPlace)).Interior.Color = RGB(0, 153, 0)
    Cells(lPlace, 1).Formula = "SUMMEN"
    Cells(lPlace, 2).Formula = "=SUM(B" & CStr(OldPlace) & ":B" & CStr(lPlace - 1) & ")"
    Cells(lPlace, 3).Formula = "=SUM(C" & CStr(OldPlace) & ":C" & CStr(lPlace - 1) & ")"
    Cells(lPlace + 1, 1).Formula = "DIFF"
    Cells(lPlace + 1, 3).Formula = "=B" & CStr(lPlace) & "+C" & CStr(lPlace)
    Cells(1, 1).Select
    Sheets(1).Select
    Cells(1, 1).Select
    Application.ScreenUpdating = True

End Sub

Den kan ikke fejle der så der må ligge andet andet bag fejlen.
Kan den køre i excel2007 ?
Det ser lidt tysk ud..du har vel ikke ændret arknavnene til dansk eller fjernet nogle?

Hvis du ikke har det, så er du velkommen til at sende arket til mig.

Jeg sletter lige noget data i den og sender den til dig. Jeg kan desvärre ikke dele projektnavnene. Jeg har ikke ändret i noget. Den  er tysk og skal bruges i tyskland.

Den förste kode kunne i köre i excel2007. Jeg kan pröve at sende dig det ark, hvor den er med i, der er ogsä forklaring til. 

Hvilken adresse/hvordan vil du gerne have det?

Mvh Fie

tommybak snabela gmail.com

modtaget og returneret.
Kører (nu) fint både i xl2007 og xl2003.

Det virker stadg ikke. Lige sä snart jeg gemmer, skriver den Compile error: Variable not defined og  markerer den xlSortOnValues i koden og det er endda inden jeg har ändret dataen til de rigtige. Jeg arbejder pä en mac, men det burde ikke have noget at sige, gör det?

I koden i den fil jeg har sendt til er der ingen xlSortOnValues der ikke er kommenteret ud med '

jeg senderlige et eksemplar hvor denne del af koden er helt fjernet.

Det virker ikke, den brokker sig nu over xlSortNormal lige sä snart jeg gemmer. og samtidig när jeg gör det, äbner der sig et vindue for hvert ark, hvori der stär Option Explicit. Tror du det kommer til at kunne fungere pä et tidspunkt eller er det en lost cause?

Sagen er den, at den sorterer fint i de förste ark, men när det kommer til projektweise sker der ingenting när jeg bruger diin rettede kode..

Hvilken excel-version er det egenlig du bruger ?
Noget tyder på at den er ældre end den ældste version jeg bruger ..

Fik lige en mistanke og fandt en gammel Excel97 og kørte koden igennem.
Ganske rigtig fejlede den ved sortering og Find sætningen.

her er en modificeret kode til den gamle excel.(og måske Mac) (regnearket er også sendt.)

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Call OpdaterArk
    Call FindProjekter

End Sub

Private Sub OpdaterArk()

    Application.ScreenUpdating = False
    Dim i As Long, j As Long, k As Long
    Dim sNames(3) As String
    Dim lPosts(3) As Long
    For i = 2 To 5
        sNames(i - 2) = Sheets(i).Name
    Next i
    Sheets(1).Select
    j = Range("F3").End(xlDown).Row
    For i = 3 To j
        For k = 0 To 3
            If LCase(Cells(i, 6)) = LCase(sNames(k)) Then
                lPosts(k) = lPosts(k) + 1
                Exit For
            End If
        Next k
    Next i
    Dim Data2() As Variant
    ReDim Data2(lPosts(0), 5)
    Dim Data3() As Variant
    ReDim Data3(lPosts(1), 5)
    Dim Data4() As Variant
    ReDim Data4(lPosts(2), 5)
    Dim Data5() As Variant
    ReDim Data5(lPosts(3), 5)
    Dim Count(3) As Long
    For i = 3 To j
        Select Case LCase(Cells(i, 6))
            Case LCase(sNames(0))
                Count(0) = Count(0) + 1
                For k = 0 To 4
                    Data2(Count(0), k) = Cells(i, k + 1).Value
                Next k
                Data2(Count(0), 5) = Cells(i, 7).Value
            Case LCase(sNames(1))
                Count(1) = Count(1) + 1
                For k = 0 To 4
                    Data3(Count(1), k) = Cells(i, k + 1).Value
                Next k
                Data3(Count(1), 5) = Cells(i, 7).Value
            Case LCase(sNames(2))
                Count(2) = Count(2) + 1
                For k = 0 To 4
                    Data4(Count(2), k) = Cells(i, k + 1).Value
                Next k
                Data4(Count(2), 5) = Cells(i, 7).Value
            Case LCase(sNames(3))
                Count(3) = Count(3) + 1
                For k = 0 To 4
                    Data5(Count(3), k) = Cells(i, k + 1).Value
                Next k
                Data5(Count(3), 5) = Cells(i, 7).Value
        End Select
    Next i
    Sheets(sNames(0)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data2, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data2(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(0)
        Cells(i + 2, 7).Value = Data2(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(1)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data3, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data3(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(1)
        Cells(i + 2, 7).Value = Data3(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(2)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data4, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data4(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(2)
        Cells(i + 2, 7).Value = Data4(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(3)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data5, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data5(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(3)
        Cells(i + 2, 7).Value = Data5(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(1).Select
    Cells(1, 1).Select
    Application.ScreenUpdating = True

End Sub

Private Sub FindProjekter()

    Application.ScreenUpdating = False
    Dim i As Long, j As Long, k As Long, lEnd As Long
    Dim sNames() As String
    Sheets("Projektweise").Select
    i = Range("A5000").End(xlUp).Row + 5
    Rows("3:" & CStr(i)).Select
    Selection.Delete Shift:=xlUp
    Sheets("Bank 09").Select
    lEnd = Range("G3").End(xlDown).Row
    ReDim sNames(0)
    For i = 3 To lEnd
        For j = 1 To 7
            Sheets("Projektweise").Cells(i, j).Value = Sheets("Bank 09").Cells(i, j).Value
        Next j
    Next i
    Sheets("Projektweise").Select
    Range("A3:Q" & CStr(lEnd)).Select
   
    Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Key2:=Range("A3") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
    ReDim sNames(0)
   
    For i = 3 To lEnd
        For j = 0 To UBound(sNames)
            If sNames(j) = Sheets("Projektweise").Cells(i, 7).Value Then Exit For
        Next j
        If j = UBound(sNames) + 1 Then
            ReDim Preserve sNames(k)
            sNames(k) = Sheets("Projektweise").Cells(i, 7).Value
            k = k + 1
        End If
    Next i
    Dim rFound As Range
    Dim lPlace As Long, OldPlace As Long
    OldPlace = 3
    For i = 1 To UBound(sNames)
        Range("G3:G" & CStr(lEnd + (UBound(sNames) * 3))).Select
        Set rFound = Selection.Find(What:=sNames(i), After:=ActiveCell, LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False)
        lPlace = rFound.Row
        Rows(CStr(lPlace) & ":" & CStr(lPlace)).Select
        Selection.Insert Shift:=xlDown
        Selection.Insert Shift:=xlDown
        Selection.Insert Shift:=xlDown
        Rows(CStr(lPlace) & ":" & CStr(lPlace)).Interior.Color = RGB(0, 153, 0)
        Cells(lPlace, 1).Formula = "SUMMEN"
        Cells(lPlace, 2).Formula = "=SUM(B" & CStr(OldPlace) & ":B" & CStr(lPlace - 1) & ")"
        Cells(lPlace, 3).Formula = "=SUM(C" & CStr(OldPlace) & ":C" & CStr(lPlace - 1) & ")"
        Cells(lPlace + 1, 1).Formula = "DIFF"
        Cells(lPlace + 1, 3).Formula = "=B" & CStr(lPlace) & "+C" & CStr(lPlace)
        OldPlace = lPlace + 3
    Next i
    lPlace = Range("G" & CStr(OldPlace)).End(xlDown).Row + 1
    Rows(CStr(lPlace) & ":" & CStr(lPlace)).Interior.Color = RGB(0, 153, 0)
    Cells(lPlace, 1).Formula = "SUMMEN"
    Cells(lPlace, 2).Formula = "=SUM(B" & CStr(OldPlace) & ":B" & CStr(lPlace - 1) & ")"
    Cells(lPlace, 3).Formula = "=SUM(C" & CStr(OldPlace) & ":C" & CStr(lPlace - 1) & ")"
    Cells(lPlace + 1, 1).Formula = "DIFF"
    Cells(lPlace + 1, 3).Formula = "=B" & CStr(lPlace) & "+C" & CStr(lPlace)
    Cells(1, 1).Select
    Sheets(1).Select
    Cells(1, 1).Select
    Application.ScreenUpdating = True

End Sub

Det virker endelig :) Det er et par ting den sorterer lidt sjovt under projektweise Fx kommer Telefon og  UST sammen selvom de ikke er de samme ord. Og sä har jeg problemer med at formatere kolonne B og C til Euro, den vil ikke rigtig acceptere det.. Men ellers virker det, koden brokker sig ikke mere !!! Mange tak for hjälpen!

Mvh
Fie