Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1568to1572
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Langsames Programm

Langsames Programm
21.07.2017 11:18:34
Franky
Hallo zusammen,
ich habe folgendes Problem und zwar habe ich mich mal an Excel versucht und ein Programm geschrieben (auch mit eurer Hilfe :)), dass Zwei Tabellen vergleicht. Die eine Tabelle in Sheets(2) ist gegeben und hat ungefähr 28000 Datensätze. Die zweite Tabelle Sheets("Schrott TT.MM") ist eine aus SAP gegebene Liste die Täglich Variiert.
Nun möchte ich jeden Datensatz der SAP Liste mit der gegebenen Liste vergleichen und bei einem Treffer soll er mir etwas Kopieren.
Der Code sieht wie folgt aus.
Sub Endprodukt_Nummer_finden()
Dim ZeileSchrott As Integer
Dim ZeileStück As Integer
Dim LetzteZeileSchrott As Integer
Dim letztezeileStück As Integer
LetzteZeileSchrott = Sheets("Schrott TT.MM").Cells(Rows.Count, 1).End(xlUp).Row
letztezeileStück = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
ZeileSchrott = 2
ZeileStück = 2
For i = 2 To LetzteZeileSchrott
For j = 2 To letztezeileStück
If Sheets("Schrott TT.MM").Cells(ZeileSchrott, 2) = "" Then
Exit For
Else
If Sheets("Schrott TT.MM").Cells(ZeileSchrott, 2) = Sheets(2).Cells(ZeileStück,  _
_
_
4) Then
Sheets(2).Cells(ZeileStück, 9).Copy _
Destination:=Sheets("Schrott TT.MM").Cells(ZeileSchrott, 6)
ZeileSchrott = ZeileSchrott + 1
ZeileStück = 2
Else
ZeileStück = ZeileStück + 1
End If
End If
Next
Next
End Sub
Mein Problem ist nun, dass ds Programm Ewigkeiten braucht, je nachdem wie groß die Liste ist, die ich aus SAP erhalte.
Hab schon mal fast 10 Min gewartet!
Ist das normal bei so einer großen Menge an Daten (28000) oder hab ich irgendwelche Anfangsfehler gemacht, die das Programm unnötig langsam machen?
Vielen Dank schonmal und für Rückfragen stehe ich jederzeit zur Verfügung :)
Gruß,
Franky

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Langsamer Code
21.07.2017 11:29:15
Fennek
Hallo,
Zugriffe auf einzene Zellen sind recht langsam, schneller geht es, wenn ein ganzer Block in ein Array geschrieben wird, dortverarbeitet und als Block ins Sheet zurückgeschrieben wird.
Ist es möglich, eine kleine Bp-Datei hochzuladen? Es gibt öfter einen Wettbewerb "wer schreibt den schnellsten Code". Vor wenigen Tagen wurde in einem der Nachbarforem eine Anfrage von Stunden in den Sekundenbereich beschleunigt.
mfg
AW: Langsamer Code
21.07.2017 11:38:41
Franky
Hallo Fennek,
danke für die Antwort.
Wie könnte das Aussehen in meinem Fall?
Kann leider die Datei nicht hochladen, weil sie 2000kb hat, es aber nur 300 erlaubt sind.
Ich versuch Sie mal zu komprimieren.
Mfg Franky
Anzeige
AW: Langsames Programm
21.07.2017 12:01:41
ransi
HAllo Franky,
Vieleicht reicht es auch schon die Excelinternenhandbremsen zu lösen.
Automatische Berechnung aus,
ereignismakros aus,
Bilschirmaktualisierung aus.
Option Explicit

Dim AppCalc
Dim AppScreen
Dim AppEvents
Dim AppCursor


Sub Endprodukt_Nummer_finden()
    Dim ZeileSchrott As Integer
    Dim ZeileStück As Integer
    Dim LetzteZeileSchrott As Integer
    Dim letztezeileStück As Integer
    With Application
        '#######################
        'Einstellungen speichern
        AppCalc = .Calculation
        AppScreen = .ScreenUpdating
        AppEvents = .EnableEvents
        AppCursor = .Cursor
        '#######################
        'Angezogene Bremsen lösen
        .Calculation = xlCalculationManual 'Berechnung auf manuell
        .ScreenUpdating = False 'Bildschirmaktualisierung aus
        .EnableEvents = False 'Ereignismakros abschalten
        .Cursor = xlDefault 'Sanduhr ausschalten
        '#######################
    End With
    LetzteZeileSchrott = Sheets("Schrott TT.MM").Cells(Rows.Count, 1).End(xlUp).Row
    letztezeileStück = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
    ZeileSchrott = 2
    ZeileStück = 2
    
    For i = 2 To LetzteZeileSchrott
        For j = 2 To letztezeileStück
            
            If Sheets("Schrott TT.MM").Cells(ZeileSchrott, 2) = "" Then
                Exit For
            Else
                If Sheets("Schrott TT.MM").Cells(ZeileSchrott, 2) = Sheets(2).Cells(ZeileStück, _
                    _
                    _
                    4) Then
                    Sheets(2).Cells(ZeileStück, 9).Copy _
                        Destination:=Sheets("Schrott TT.MM").Cells(ZeileSchrott, 6)
                    
                    ZeileSchrott = ZeileSchrott + 1
                    ZeileStück = 2
                    
                Else
                    ZeileStück = ZeileStück + 1
                End If
            End If
        Next
    Next
    With Application
        .Calculation = AppCalc
        .ScreenUpdating = AppScreen
        .EnableEvents = AppEvents
        .Cursor = AppCursor
    End With
End Sub


ransi
Anzeige
AW: Langsames Programm
21.07.2017 12:38:00
Franky
Hallo Ransi,
danke ich werde es gleich mal ausprobieren.
Mfg Franky
AW: Langsames Programm
21.07.2017 12:25:57
Fennek
Hallo,
wer hat den diesen Code geschrieben?
Nach einer ersten Durchsicht möchte ich folgende Änderung für das Makro "kopieren" vorschlagen:

Sub Daten_Kopieren()
Dim LetzteZeile As Integer
Dim Zeile As Integer
LetzteZeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'######### was ist Sheets(1): Infosätze?
Worksheets("Schrott SAP").UsedRange.Copy _
Destination:=Worksheets("Schrott TT.MM").Cells(2, 2)
End Sub
Die Refenrenzierung mit "Sheets(1)" sind nicht nachvollziehbar.
Den Code mit Autostart auszuführen, ist "komplet daneben".
mfg
Anzeige
AW: Langsames Programm
21.07.2017 12:43:02
Franky
Hallo Fennek,
das war ich, mit meinen sehr bescheidenen Excel VBA Kenntnissen.
In Sheets 1 wird die SAP Asuwertung gespeichert.
Von dieser Kopiere ich dann einige Teile in den Worksheets("Schrott TT.MM").
Was meinst mit Autostart, bzw warum ist das daneben?
Hättest du auch eine Lösung für den Sub Endprodukt_Nummer_finden()? :)
Mfg,
Franky
AW: Langsames Programm
21.07.2017 13:58:49
Fennek
Hallo,
nach einer erneuten Durchsicht, dies sind meine Vorschläge für
-Kopieren
-MateriaNrsuchen

Sub Daten_Kopieren()
Dim LetzteZeile As Integer
Dim Zeile As Integer
LetzteZeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Zeile = 2
With Sheets("Schrott SAP")
.Rows("1:2").Insert
With .Range("A1:L1")
.Formula = "=column()"
.Value = .Value
End With
sp = Array(99, 98, 2, 97, 96, 3, 95, 94, 1, 4, 93, 5)
Cells(2, 1).Resize(, UBound(sp) + 1) = Application.Transpose(Application.Transpose(sp))
'Sortieren zum Kopieren
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range( _
"A2:L2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With .Sort
.SetRange Cells(1).CurrentRegion 'Range("A1:L33")
.Header = xlNo
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
lr = .Cells(Rows.Count, "A").End(xlUp).Row
Range("A3:E" & lr).Copy Sheets("Schrott TT.MM").Cells(1, "J")
'Zurücksortieren
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range( _
"A1:L1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With .Sort
.SetRange Cells(1).CurrentRegion 'Range("A1:L33")
.Header = xlNo
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
Rows("1:2").Delete
end sub
Sub Endprodukt_Nummer_finden()
Dim ZeileSchrott As Long
Dim ZeileStück As Long
Dim LetzteZeileSchrott As Long
Dim letztezeileStück As Long
Dim rng As Range
LetzteZeileSchrott = Sheets("Schrott TT.MM").Cells(Rows.Count, 1).End(xlUp).Row
letztezeileStück = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
ZeileSchrott = 2
ZeileStück = 2
With Sheets("Stückliste NOC")
For i = 2 To LetzteZeileSchrott
Such = Sheets("Schrott TT.MM").Cells(i, 2)
Set rng = .Columns("D").Find(Such, LookIn:=xlValues, lookat:=xlWhole)
If Not rng Is Nothing Then
Debug.Print Such, "Material ", .Cells(rng.Row, "I")
End If
Next i
End With
end sub
Ich habe den Eindruck, dass der VBA-Code nicht mit den Daten im Sheet "Schrott MM.TT" übereinstimmt.
mfg
Anzeige
AW: Langsames Programm
21.07.2017 14:09:50
Franky
Hallo Fennek,
vielen Dank dafür, dass du nochmal drüber geschaut hast.
Das es nicht übereinstimmt liegt vllt daran, das ich von den Daten in Sheet2 ca. 26000 gelöscht hab, damit ich die Datei Hochladen konnte. :)
Ich werd das mal ausprobieren. Schönes Wochenende wünsch ich dir.
Mfg Franky
AW: Version2
21.07.2017 17:45:44
Fennek
Hallo,
teste mal diesen Code:

Sub Daten_Kopieren()
Dim Res()
Dim rng As Range
S_SAP = Worksheets("Schrott SAP").Cells(1).CurrentRegion
ReDim Res(UBound(S_SAP), 7)
For i = 1 To UBound(S_SAP)
'Material
Res(i - 1, 1) = S_SAP(i, 3)
'Bezeichnung
Res(i - 1, 2) = S_SAP(i, 6)
'Datum
Res(i - 1, 0) = S_SAP(i, 9)
'Menge
Res(i - 1, 3) = S_SAP(i, 10)
'Preis
Res(i - 1, 4) = S_SAP(i, 12)
Zeile = Zeile + 1
Next
With Sheets("Schrott TT.MM")
.Cells(1, "J").Resize(UBound(S_SAP), 7) = Res
lr_s = .Cells(Rows.Count, "A").End(xlUp).Row
'Endprodukt_Nummer_finden
For i = 2 To lr_s
Such = .Cells(i, 2)
Set rng = Sheets("Stückliste NOC").Columns("D").Find(Such, LookIn:=xlValues, Lookat:= _
xlWhole)
If Not rng Is Nothing Then .Cells(i, "F") = Sheets("Stückliste NOC").Cells(rng.Row, "I") _
Next i
'Spalte G-H aus "Sheets("Infosätze")
lr_i = Sheets("Infosätze").Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lr_s
Set rng = Sheets("Infosätze").UsedRange.Columns("B").Find(.Cells(i, 2), LookIn:=xlValues,  _
Lookat:=xlWhole)
If Not rng Is Nothing Then
.Cells(i, "G") = Sheets("Infosätze").Cells(rng.Row, 3)
.Cells(i, "H") = Sheets("Infosätze").Cells(rng.Row, 7)
End If
Next i
End With
End Sub
Versuche den Code zu verstehen, es kann sein, dass der ein oder andere Index verrutsch ist.
mfg
Anzeige
AW: Version2
24.07.2017 10:10:51
Franky
Hey Fennek,
zurück aus dem Wochenende hab ich gleich mal deinen Code ausprobiert.
Passt zwar alles super, aber er sucht leider immer noch ewig.
Ich glaub das liegt einfach an der Unmenge an Daten die es zu vergleichen gilt.
Trotzdem viele dank für die 2. Version!! :)
Mfg
Franky
AW: Match im Array
24.07.2017 10:36:07
Fennek
Hallo,
schreibe den Code so um, dass die Suche nach Endproduktnummern und Infosätze in einem Array erfolgt. Da sollte deutlich schneller werden.
mfg
AW: Version 3
24.07.2017 13:22:02
Fennek
Hallo,
jetzt nur mit Arrays. Da es im bereitgestellten Datensatz keine Matches gibt, muss der Code gründlich debugged werden.

Sub Daten_Kopieren_V3()
Dim Res()
S_SAP = Worksheets("Schrott SAP").Cells(1).CurrentRegion
ReDim Res(UBound(S_SAP), 7)
For i = 1 To UBound(S_SAP)
'Material
Res(i - 1, 1) = S_SAP(i, 3)
'Bezeichnung
Res(i - 1, 2) = S_SAP(i, 6)
'Datum
Res(i - 1, 0) = S_SAP(i, 9)
'Menge
Res(i - 1, 3) = S_SAP(i, 10)
'Preis
Res(i - 1, 4) = S_SAP(i, 12)
Zeile = Zeile + 1
Next
With Sheets("Schrott TT.MM")
Noc = Sheets("Stückliste NOC").Cells(1).CurrentRegion
Inf = Sheets("Infosätze").Cells(1).CurrentRegion
For i = 2 To UBound(S_SAP)
'Endprodukt_Nummer_finden
For ii = 2 To UBound(Noc)
If Res(i, 2) = Noc(ii, 4) Then Res(i, 5) = Noc(i, 9)
Next ii
'Spalte G-H aus "Sheets("Infosätze")
For ii = 2 To UBound(Inf)
If Res(i, 2) = Inf(ii, 2) Then
Res(i, 6) = Inf(ii, 3)
Res(i, 7) = Inf(ii, 7)
End If
Next ii
Next i
'### zurückschtreiben ###
.Cells(1, "A").Resize(UBound(S_SAP), 7) = Res
End With
'Set Res = Nothing
Set S_SAP = Nothing
Set Noc = Nothing
Set Inf = Nothing
End Sub
mfg
Anzeige
AW: Langsames Programm
24.07.2017 14:56:36
Tino
Hallo,
habe es mal so versucht, evtl. passt es ja.
Hoffe das ich alles aus deinem Code verstanden und richtig umgeschrieben habe!
Sub Endprodukt_Nummer_finden()
Dim rngZiel As Range, varSuch, varErg
Dim ArDataSAP
Dim oDic As Object
Dim n&, nn&
With Sheets("Stückliste NOC")
ArDataSAP = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 9).Value2
End With
With Sheets("Schrott TT.MM")
Set rngZiel = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 6)
varSuch = rngZiel.Columns(2).Value2
varErg = rngZiel.Columns(6).Value2
End With
Set oDic = CreateObject("Scripting.Dictionary")
For n = 1 To UBound(varSuch)
If n > 1 Then
If oDic.exists(varSuch(n, 1)) Then
varErg(n, 1) = oDic(varSuch(n, 1))
End If
Else
For nn = LBound(ArDataSAP) To UBound(ArDataSAP)
oDic(ArDataSAP(nn, 4)) = ArDataSAP(nn, 9)
If varSuch(n, 1) = ArDataSAP(nn, 4) Then
varErg(n, 1) = ArDataSAP(nn, 9)
End If
Next nn
End If
Next
rngZiel.Columns(6).Value = varErg
End Sub
Gruß Tino
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige