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
|