Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 17:05:40
Zählen von Zeilen, in denen in bestimmten Bereich Daten sind
19.04.2024 16:34:52
gemeinsamer Filter über drei Spalten
19.04.2024 15:39:42
Exceltabelle daten per combobox zu word Datei
19.04.2024 14:04:05
PDF per VBA ausgeben - Seitenskalierung
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1400to1404
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1400to1404
1400to1404
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Archiv-Suche beschleunigen möglich?

Archiv-Suche beschleunigen möglich?
06.01.2015 16:10:47
dani
Hallo Excel-Cracks
Ich hoffe, Ihr seid gut ins neue Jahr gestartet.
Ich arbeite viel mit Excel und habe mir auch einiges an VBA-Wissen angeeignet.
Den VBA-Code, um den es geht, habe ich vor einiger Zeit programmieren lassen. Es handelt sich um eine gezielte Suche in einem Artikelarchiv (wird regelmässig in Excel-Datei als neues Blatt angelegt). Je länger meine Kalkulation nun im Gebrauch ist, desto grösser wird das Archiv und umso länger sucht der Code die nötigen Informationen für mich heraus. Lange Einleitung, kurze Frage: Ist es möglich, die Artikel-Suche zu beschleunigen? Das übersteigt nämlich meine VBA-Kenntnisse.
Vielen Dank bereits im Voraus für eure Hilfe!
Hier der entsprechende Auszug aus dem gesamten Code (mit den Bezeichnungen der Worksheets, aber ohne für die Suche Unrelevantes):
For Each blatt In ActiveWorkbook.Sheets
If (blatt.name SH_VORB_VPEIGENPRSAP And blatt.name SH_VORB_VPSAP) Then
blatt.Select
Set foundRange = blatt.Columns("A:A").Find(artNr, LookIn:=xlValues)
If Not foundRange Is Nothing Then
blatt.Range("B" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("e" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("C" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("f" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("D" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("g" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("E" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("h" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("F" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("i" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("G" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("j" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("H" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("k" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("I" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("l" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
blatt.Range("J" & foundRange.row).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("m" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
startRow = startRow + 1
End If
End If
Next
End Sub

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Archiv-Suche beschleunigen möglich?
06.01.2015 16:30:20
daniel
Hi
Ein Problem ist, dass jede Zelle einzeln kopiert wird, dass ist nicht notwendig:
For Each blatt In ActiveWorkbook.Sheets
If (blatt.name SH_VORB_VPEIGENPRSAP And blatt.name SH_VORB_VPSAP) Then
Set foundRange = blatt.Columns("A:A").Find(artNr, LookIn:=xlValues)
If Not foundRange Is Nothing Then
blatt.Range("B" & foundRange.row).Resize (1, 9).Copy
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Range("e" & startRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
startRow = startRow + 1
End If
End If
Next
Um die suche ansichh zu besteht beschleunigen, müsstest du ganz anders vorgehen, bspw alle Daten auf ein blatt schreiben, sortieren und dann mit worksheetfunction.match suchen.
Gruss Daniel

Anzeige
AW: Archiv-Suche beschleunigen möglich?
06.01.2015 16:39:10
fcs
Hallo Dani,
da die zu kopierenden Zellen in Quell und Zieltabelle als Block nebeneinander liegen kann man den Kopiervorgang auch als Block durchführen.
Zusätzlich kann man einige Einstellungen vorübergehend so setzen, dass die Ausführung des makros beschleunigt wird.
Gruß
Franz 
Sub aaTest()
Dim wksZiel As Worksheet
Dim StatusCalc As Long
'Zieltabelle setzen
Set wksZiel = Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE)
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
For Each blatt In ActiveWorkbook.Sheets
Select Case blatt.Name
Case SH_VORB_VPEIGENPRSAP, SH_VORB_VPSAP
'diese Blätter nicht durchsuchen
Case Else
blatt.Select
Set foundRange = blatt.Columns("A:A").Find(artNr, LookIn:=xlValues)
If Not foundRange Is Nothing Then
With blatt
.Range(.Cells(foundRange.Row, 2), .Cells(foundRange.Row, 10)).Copy ' _
Spalten B bis J
End With
'in Zieltabelle in Zeile ab Spalte E einfügen
wksZiel.Cells(startRow, 5).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlPasteSpecialOperationNone
startRow = startRow + 1
End If
End Select
Next
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End Sub

Anzeige
AW: Archiv-Suche beschleunigen möglich?
06.01.2015 17:04:47
Rudi
Hallo,
noch einer: 
  Set oDic = CreateObject("Scripting.dictionary")
For Each blatt In Worksheets
If (blatt.Name  SH_VORB_VPEIGENPRSAP And blatt.Name  SH_VORB_VPSAP) Then
Set FoundRange = blatt.Columns(1).Find(ArtNr)
If Not FoundRange Is Nothing Then
oDic(oDic.Count + 1) = FoundRange.Offset(, 1).Resize(, 9).Value
End If
Next blatt
End If
If oDic.Count Then
arrItems = oDic.items
ReDim arrOut(1 To oDic.Count, 1 To 9)
For i = 0 To UBound(arrItems)
For j = 1 To 9
arrOut(i + 1, j) = arrItems(i)(1, j)
Next
Next
Workbooks(WB_DETAILPREISKALK).Sheets(SH_ARTIKELSUCHE).Cells(StartRow, 5).Resize(UBound( _
arrOut), UBound(arrOut, 2)) = arrOut
End If

Gruß
Rudi

Anzeige
AW: Archiv-Suche beschleunigen möglich?
06.01.2015 17:17:50
dani
Hallo zusammen
Vielen Dank erst Mal an alle für eure super-schnelle Hilfe.
Nun habe ich die Qual der Wahl, was für ein Luxus-Problem :-)
@ Daniel: Danke, ich konnte deine Idee testen. Das Makro funktioniert wirklich viel schneller als vorher.
@ Franz: Dein Code läuft auch sauber durch, bringt jedoch die Werte nicht. Also die Zielzellen werden angesteuert, bleiben jedoch leer. Da mache ich wohl noch etwas falsch.
@ Rudi: Ich teste deine Version heute Abend und melde mich dann wieder.
Bis später
Grüsse
Dani

AW: Archiv-Suche beschleunigen möglich?
06.01.2015 21:35:23
Dani
Hallo Rudi
Vielen Dank nochmals für deinen Lösungsansatz. Ich bin damit noch nicht so weit gekommen, da ich die Fehlermeldung "next ohne for" erhalte und zwar an dieser Stelle des Codes, bei "Next blatt":
If Not foundRange Is Nothing Then
oDic(oDic.Count + 1) = foundRange.Offset(, 1).Resize(, 9).Value
End If
Next blatt
 End If
und das obwohl ja ein "End if" davor steht.
Weisst, du, wieso das Makro stoppt?
Flotte Grüsse
Dani

Anzeige
In Rudis Code sind 2 Zeilen vertauscht, ...
07.01.2015 01:50:00
Luc:-?
…Dani,
das 2. EndIf muss vor dem Next blatt stehen!
Morrn, Luc :-?

AW: In Rudis Code sind 2 Zeilen vertauscht, ...
12.01.2015 16:03:50
Dani
Hallo Luc
Vielen Dank für den Hinweis und sorry für meine etwas späte Reaktion.
Viele Grüsse
Dani

...mit der ich nicht mehr gerechnet hatte! ;-] owT
12.01.2015 16:43:49
Luc:-?
:-?

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige