22.05.2019, 10:03
Hallo Leute,
ich verwende im Augenblick folgenden Code, im Prinzip nur eine "Find" Funktion , ich bin aber mit der Geschwindigkeit nicht zufrieden, ein Durchlauf umfasst 5000-10000 Zeilen und benötigt ca 15-20 Sekunden, das ist mit zu lange für so eine Abfrage. Jemand eine Idee wie man das anders uns schneller, machen könnte? Danke !
ich verwende im Augenblick folgenden Code, im Prinzip nur eine "Find" Funktion , ich bin aber mit der Geschwindigkeit nicht zufrieden, ein Durchlauf umfasst 5000-10000 Zeilen und benötigt ca 15-20 Sekunden, das ist mit zu lange für so eine Abfrage. Jemand eine Idee wie man das anders uns schneller, machen könnte? Danke !
Code:
Sub Rüstung_Check()
Dim Pfad As String
Dim letzte As Long
Dim letzte2 As Long
Dim wkbName As String
Dim QsName As String
Dim SMsName As String
'Quelldatei
Pfad = "\\hisrwsfs01\l_neu\MES-I\Bestueckung\ASM_Rüstungen\01_Muster\"
'Quell Workbook Name
wkbName = "01_Rüstlisten_Tool.xls"
'Quell Sheet Name
QsName = "Rüstung"
' Suchmaske Workbook Name
wkbMaske = Application.ActiveWorkbook.Name
'Suchmaske Sheet Name
SMsName = "Suchen"
' Importierte Rüstungen
SHRüstung = "D"
' Importierte Programme
SHProgram = "IMP"
' Löschen vorherige Eingabe
'Range("H6:N100").ClearContents
' Letzte zeile Quell Workbook finden
'letzte = Workbooks(wkbName).Sheets(QsName).Cells(Rows.Count, 5).End(xlUp).Rows.Row
letzte = 10000
letzte2 = Workbooks(wkbMaske).Sheets(SHProgram).Cells(Rows.Count, 2).End(xlUp).Rows.Row
' Fehlende Sachnummern finden
Workbooks(wkbMaske).Sheets(SMsName).Range("F8", "F200").ClearContents
Application.Calculation = xlCalculationManual
QuellZelle2 = 1
ZielZelle = 8
FehlendeBt = 0
For D = QuellZelle2 To letzte2
Set Found = Sheets(SHRüstung).Columns(5).Find(Sheets(SHProgram).Cells(QuellZelle2, 2), LookIn:=xlValues, LookAt:=xlWhole)
If Found Is Nothing Then
Zeile1 = Workbooks(wkbMaske).Sheets(SHProgram).Cells(QuellZelle2, 2).Value
Workbooks(wkbMaske).Sheets(SMsName).Cells(ZielZelle, 6).Value = Zeile1
QuellZelle2 = QuellZelle2 + 1
ZielZelle = ZielZelle + 1
FehlendeBt = 1
Else
QuellZelle2 = QuellZelle2 + 1
End If
Next D
If FehlendeBt = 1 Then
MsgBox "Achtung! Es Fehlen Bauteile in der Rüstung"
Else
MsgBox "Rüstung komplett!"
End If
On Error Resume Next
Workbooks(wkbMaske).Sheets(SMsName).Range("F8:F" & ZielZelle).RemoveDuplicates Columns:=1, Header:=xlNo
Application.Calculation = xlCalculationAutomatic
End Sub