Hallo zusammen

Ich habe ein File in welchem ich Spezifikationen eines Produktes eingeben kann. Mein Makro soll diese Eingaben nun mit einer Liste abgleichen. Falls bereit ein gleiches Produkt (in der selben Farbe, Grösse usw.) in der Liste ist, soll nur die Anzahl des Produktes in der Liste verändert werden. Ansonsten ein neuer Eintrag generiert werden.

Mein Problem ist nun, dass die Berechnung sehr sehr langsam ist (musste den Prozess abbrechen). Leider wurden jedoch in beiden Fällen - neues und in Liste bestehendes Produkt- viele gleiche neue Einträge angelegt, was nach meiner - scheinbar falschen - Logik nicht sein sollte.

Wo liegt mein Denkfehler? Wie kann ich das ganze besser machen?

Option Explicit
 
Sub Verkaufen2()
'
' Bestellen Makro
'
 Dim Marke As String
 Dim Standort As String
 Dim WSh As Worksheet
 Dim WKb As Workbook
 Dim ThisPos As Range
 Dim ThisPos2 As Range
 Dim Anzahl As Long
 Dim Model As String
 Dim ThisRow As Long
 Dim ThisRow2 As Long
 Dim Monat As String
 Dim Einheit As Long
 Dim Farbe As String
 Dim Zeile As Long
   
  
 With ThisWorkbook.Sheets("Verkaufsformular")
 
'Überprüfen ob Zellen ausgefüllt sind
    If IsEmpty(.Range("C5")) Then
        MsgBox ("Bitte Anzahl einfügen!")
        Exit Sub
    ElseIf IsEmpty(.Range("D5")) Then
        MsgBox ("Bitte Einheit einfügen!")
        Exit Sub
    ElseIf IsEmpty(.Range("E5")) Then
        MsgBox ("Bitte Marke einfügen!")
        Exit Sub
    ElseIf IsEmpty(.Range("F5")) Then
        MsgBox ("Bitte Model einfügen!")
        Exit Sub
    ElseIf IsEmpty(.Range("G5")) Then
        MsgBox ("Bitte Farbe einfügen!")
        Exit Sub
    ElseIf IsEmpty(.Range("H5")) Then
        MsgBox ("Bitte Standort einfügen!")
        Exit Sub
    End If
  
   Marke = .Range("E5").Value
   Standort = .Range("H5").Value
   Model = .Range("F5").Value
   Einheit = .Range("D5").Value
   Farbe = .Range("G5").Value
  
'In passendes File einfügen

    If InStr("Aarau,Baden,Haselstrasse,Luzern,Reinach", Standort) > 0 Then
    

'In passendes Tab einfügen
  
        If InStr("Finn Comfort,FootJoy,Meindl,New Balance,Steitz,Künzli,Lloyd,Anova Xelero,Stucco,Uvex,Bort (Orthosan),Bauerfeind,Sascha Herzog,Lyreco,Perpedes,Ottobock,Orthoservice,Sigvaris,Smedico,Zbinden,Rudolf Roth,Juzo,Berro,Jobst,Oped,Össur,Swissmed,Divers", Marke) > 0 Then
   
'Zieldatei öffnen
            Set WKb = Workbooks.Open("I:\Domenic Stamm\Verkaufslisten\Verkaufsliste " & Standort & ".xlsm")
            Set WSh = WKb.Worksheets(Marke)
            
            Set ThisPos = WSh.Range("D:D").Find(What:=Model, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)    'ist bereits eine Ausgabe diese Models in der Liste?
            
            If Not ThisPos Is Nothing Then                                                                              'falls eines in der Liste vorhanden ist:
                Do
                ThisRow = ThisPos.Row                                                                                   'Zeilenzahl des Models
                Monat = WSh.Range("G" & ThisRow).Value
                If Monat = MonthName(Month(Now)) And Einheit = WSh.Range("B" & ThisRow).Value And Farbe = WSh.Range("E" & ThisRow).Value Then           '...und wurde es im selben Monat, selbe Grösse und Farbe verkauft?
                    Zeile = ThisRow                                                                                     'falls alles übereinstimmt, muss die Zeilennummer gespeichert und die Schleife verlassen werden.
                    Exit Do
                    
                Else
                End If
                Set ThisPos2 = WSh.Range("D:D").FindNext(ThisPos)                                                       'Die Position des nächsten Models eruieren.
                ThisRow2 = ThisPos2.Row
                If (ThisRow2 <= ThisRow) Then                                                                              'Da die While-Schleife immer wieder oben in der Liste beginnt, sobald sie den letzten Eintrag geprüft hat, muss geprüft werden, ob die neu gefundene Zeilennummer grösser ist als die bestehende um sie weiter zu verwenden. Ansonsten muss die Schleife verlassen werden.
                    Exit Do
                Else
                    ThisPos = ThisPos2
                End If
                Loop While Not ThisPos Is Nothing
                If IsEmpty(Zeile) = True Then
                    WSh.Range("A2").EntireRow.Insert CopyOrigin:=xlFormatFromRightOrBelow
                    WSh.Range("A2").Resize(1, 6).Value = .Range("C5:H5").Value
                    WSh.Range("G2").Value = MonthName(Month(Now))
                Else
                    Anzahl = WSh.Range("A" & Zeile).Value
                    WSh.Range("A" & Zeile).Value = Anzahl + 1
                End If
            Else
                WSh.Range("A2").EntireRow.Insert CopyOrigin:=xlFormatFromRightOrBelow
                WSh.Range("A2").Resize(1, 6).Value = .Range("C5:H5").Value
                WSh.Range("G2").Value = MonthName(Month(Now))
            End If
            WKb.Close SaveChanges:=True
            .Range("C5:H5").ClearContents         'Nur löschen bei gültiger Marke
        End If
        
    End If
  
 End With
  
End Sub

Besten Dank schon Mal im voraus. 

LG staeme