Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
928to932
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
928to932
928to932
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

VBA Mehrspaltenabfrage statt Matrixformel

VBA Mehrspaltenabfrage statt Matrixformel
21.11.2007 16:44:47
Pascal
Hallo zusammen,
folgendes Problem: Ich suche in Tabelle A Werte in Tabelle B in Abhängigkeit von drei Spalten, deren Werte in beiden Tabellen identisch sein müssen.
Hierzu verwendete ich bislang folgende Matrixfunktion:
{=VERGLEICH($C347*1&"|"&$D347*1&"|"&$E347*1; Pfad_und_Datei!$B$4:$B$2500*1 &"|"&Pfad_und_Datei!$C$4:$C$2500*1 &"|"&Pfad_und_Datei!$D$4:$D$2500*1; 0) }
Da ich die Tabelle nun für die allgemeine Verwendung frei geben wollte, kann ich keine Matrixfunktion mehr verwenden. (Matrixfunktion und Freigabe beißen sich.) Bleibt also VBA.
Beide Dokumente haben jew. 2.000 Zeilen. Wenn ich das jetzt via verschachtelter For/Next/ IF Then durchführe, dauert das Makro recht lange, da es sich um 4 Mio Abfragen handelt.
Gibt es eine Möglichkeit, das eleganter zu lösen?
Danke und schöne Grüße,
Pascal

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Mehrspaltenabfrage statt Matrixformel
21.11.2007 16:53:01
Renee
Hi Pascal,
Matrixfunktion und Freigabe beißen sich. Ach nee...
Matrixformeln in freigegebenen Mappen werden ohne Probleme richtig berechnet!
Die Einschränkung für Matrixformeln in freigegebene Mappen sind, dass bestehende nicht abgeändert und neue nicht hinzugefügt werden können.
Mit VBA wirst Du noch mehr Probleme haben, da Makros in solchen nicht zugelassen sind!
GreetZ Renee

AW: VBA Mehrspaltenabfrage statt Matrixformel
21.11.2007 17:02:26
Jan
Hi,
"...Mit VBA wirst Du noch mehr Probleme haben, da Makros in solchen nicht zugelassen sind!..."
Irrtum!
mfg Jan

AW: VBA Mehrspaltenabfrage statt Matrixformel
21.11.2007 17:05:39
Pascal
Hallo Renee,

"Matrixformeln in freigegebenen Mappen werden ohne Probleme richtig berechnet!"

schon mal ausprobiert? Bei mir geht es nicht!
Wenn ich die Tabelle freigeben möchte, erscheint folgende Fehlermeldung:
"Tabelle kann nicht freigegeben werden, weil Matrixformel enthalten sind, die sich auf andere Arbeitsmappen beziehen." Freigabe ist nicht möglich. Wenn ich alle Matrixformel entferne kann ich die Tabelle auch mit allen Makros für alle freischalten.
Die Makros lassen sich übrigens für alle Benutzer verwenden (bereits erfolgreich mit 4 verschiedenen Benutzern ausprobiert. Kein Problem trotz Sortierungen etc.)
Beste Grüße,
Pascal

Anzeige
AW: VBA Mehrspaltenabfrage statt Matrixformel
21.11.2007 17:29:05
Renee
Hi Pascal,
Den Teil "...die sich auf andere Arbeitsmappen beziehen." hast du in der Anfrage leider vergessen.
Na dann, viel Glück.
GreetZ Renee
P.S. Um Code optimieren zu können, müsste man ihn sehen.

Codeoptimierung
22.11.2007 16:13:12
Pascal
Hi Renee,
da hast Du nicht ganz unrecht. Sorry dafür.
Also, ich habe mich da einmal hingesetzt. Leider habe ich keinerlei Erfahrungen mir Verweisen auf andere Tabellen, daher ist der Code mit recht vermurkst. Vielleicht hat jemand eine (wahrscheinlich mehrere) Optimierungsidee(n)?

Sub Werteübernahme_Projektliste_TNI()
Dim rngSource As Range, rngTarget As Range
Dim i, j, k As Integer
Workbooks("Projekte A.xls").Activate
Sheets("Projekte").Select
PFAD = "U:\T\_Pfad\Projektübersicht.xls"
XS = "Projektübersicht.xls"
XS_WS = "Projektübersicht"
' Letzte Reihe bestimmen
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
Workbooks.Open PFAD
For j = 4 To LastRow
Workbooks("Projekte A.xls").Activate
X1 = Worksheets("Projekte").Cells(j, 2).Value
X2 = Worksheets("Projekte").Cells(j, 3).Value
X3 = Worksheets("Projekte").Cells(j, 4).Value
Workbooks(XS).Activate
For i = 4 To 2500
Y1 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 1).Value
Y2 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 2).Value
Y3 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 3).Value
Y4 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 69).Value
If X1 = Y1 And X2 = Y2 And X3 = Y3 And X4  "" Then MsgBox "Wert zur Ü _
bertragung in erste Arbneitsmappe gefunden"
Next i
Next j
End Sub


Besten Dank für Eure Hilfe,
Pascal

Anzeige
AW: Codeoptimierung
22.11.2007 16:20:19
Renee
Hi Pascal,
Ein Optimierungsidee:

Sub Werteübernahme_Projektliste_TNI()
Dim rngSource As Range, rngTarget As Range
Dim i, j, k As Integer
Dim lSaveCalc As Long
Workbooks("Projekte A.xls").Activate
Sheets("Projekte").Select
PFAD = "U:\T\_Pfad\Projektübersicht.xls"
XS = "Projektübersicht.xls"
XS_WS = "Projektübersicht"
' Letzte Reihe bestimmen
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
Workbooks.Open PFAD
lSaveCalc = Application.Calculation
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For j = 4 To LastRow
Workbooks("Projekte A.xls").Activate
X1 = Worksheets("Projekte").Cells(j, 2).Value
X2 = Worksheets("Projekte").Cells(j, 3).Value
X3 = Worksheets("Projekte").Cells(j, 4).Value
Workbooks(XS).Activate
For i = 4 To 2500
Y1 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 1).Value
Y2 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 2).Value
Y3 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 3).Value
Y4 = Workbooks(XS).Worksheets(XS_WS).Cells(i, 69).Value
If X1 = Y1 And X2 = Y2 And X3 = Y3 And X4  "" Then _
MsgBox "Wert zur Übertragung in erste Arbneitsmappe gefunden"
Next i
Next j
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = lSaveCalc
End Sub


GreetZ Renee

Anzeige
AW: Codeoptimierung
22.11.2007 16:40:00
Harry
Hallo Pascal,
da hier die Laufzeit maßgeblich durch das wiederholte Auslesen gleicher Zellen bestimmt wird, benutzte einfach Arrays nach folgenden Schema

Sub Werteübernahme_Projektliste_TNI()
Dim rngSource As Range, rngTarget As Range
Dim i, j, k As Integer
Dim lSaveCalc As Long
Dim arrSource
Dim arrTarget
Workbooks("Projekte A.xls").Activate
Sheets("Projekte").Select
PFAD = "U:\T\_Pfad\Projektübersicht.xls"
XS = "Projektübersicht.xls"
XS_WS = "Projektübersicht"
' Letzte Reihe bestimmen
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
Workbooks.Open PFAD
lSaveCalc = Application.Calculation
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'!!! Einlesen der Arrays nicht getestet
ReDim arrSource(4 To LastRow, 1 To 3)
arrSource = Workbooks("Projekte A.xls").Worksheets("Projekte").Range("B4:D" & LastRow)
ReDim arrTarget(4 To 2500, 1 To 4)
arrTarget = Union(Workbooks(XS).Worksheets(XS_WS).Range("A4:C2500"), Workbooks(XS). _
Worksheets(XS_WS).Range("BQ4:BQ2500"))
For j = 4 To LastRow
For i = 4 To 2500
If arrSource(j, 1) = arrTarget(j, 1) And arrSource(j, 2) = arrTarget(j, 2) And  _
arrSource(j, 3) = arrTarget(j, 3) And arrTarget(j, 4)  "" Then _
MsgBox "Wert zur Übertragung in erste Arbneitsmappe gefunden"
Next i
Next j
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = lSaveCalc
End Sub


Gruß
Harry

Anzeige
AW: Codeoptimierung
22.11.2007 16:56:02
Harry
Update: Einlesen der Arrays besser so

'!!! Einlesen der Arrays nicht getestet
ReDim arrSource(4 To LastRow, 1 To 3)
For i = 4 To LastRow
For j = 1 To 3
arrSource(i, j) = Workbooks("Projekte A.xls").Worksheets("Projekte").Cells(i, j + 1) _
Next
Next
ReDim arrTarget(4 To 2500, 1 To 4)
For i = 4 To 2500
For j = 1 To 3
arrTarget(i, j) = Workbooks(XS).Worksheets(XS_WS).Cells(i, j)
Next
arrTarget(i, 4) = Workbooks(XS).Worksheets(XS_WS).Cells(i, 69)
Next


Gruß
Harry

AW: Codeoptimierung
22.11.2007 17:06:00
Pascal
Hallo Harry, hallo Renee,
besten Dank für Eure Mühe.
@Renee Das geht schon schneller, aber leider immer noch deutlich zu langsam.
@Harry. DAs sieht super aus und scheint mir der richtige Ansatz. Mir ist hier jetzt leider etwas dazwischen gekommen, so dass ich das erst heute Nacht oder morgen ausprobieren kann.
Ich werde dann berichten.
Pascal

Anzeige
AW: Codeoptimierung
22.11.2007 17:54:00
Harry
Hallo Pascal,
2. Update, muss natürlich so heißen

If arrSource(j, 1) = arrTarget(i, 1) And arrSource(j, 2) = arrTarget(i, 2) And _
arrSource(j, 3) = arrTarget(i, 3) And arrTarget(i, 4)  "" Then _
MsgBox "Wert zur Übertragung in erste Arbneitsmappe gefunden"


Gruß
Harry

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige