AW: Brauche Hilfe beim Aufbau eines Array
05.07.2010 10:02:16
fcs
Hallo Holger,
Kurz gesagt, wie kann man ein Array anhand eines Parameters aufbauen?
Indem man die Größe des Arrays dynamisch bestimmt und über entsprechende If-Bedingungen nur die gewünschten Daten einliest.
Schaut dann etwa wie folgt aus. Ich hab hier jetzt "nur" die Zeilennummern der Trefferzeilen ins Array eingelesen und greife beim Einlesen der Daten in die Tabelle1 über die Zeilennummer auf die Daten in Tabelle2 zu. Du kannst das Array natürlich auch mit entsprechend mehr Spalten versehen und alle gewünschten Daten ins Array einlesen und später dann auch aus dem Array in die Tabelle 1 einlesen.
Derart geschachtelte Suchschleifen machen sich in der Laufzeit aber erst deutlich bemerkbar, wenn die innere Schleife jedesm Mal mehrere Hundert Zeilen abarbeiten muss. Prüfe also ob in deiner Prozedur noch andere Bremsen enthalten sind (Bildschirmaktualisierung, Berechnungsmodus, Ereignismakros).
Bei sehr vielen Datenzeilen (mehrere Tausend) in Tabelle2 ist es ggf. geschickter die Suchfunktion in Verbindung mit einer Do..Loop-Schleifen einzusetzen, um die Trefferzeile zu finden.
Gruß
Franz
Sub Tabs_abgleichen()
Dim wks1 As Worksheet, wks2 As Worksheet, sSuchen As String
Dim Zeile1 As Long
Dim arr2 As Variant, iIndex As Long
Set wks2 = Worksheets("Tab2") 'Tabelle mit Quelldaten
Set wks1 = Worksheets("Tab1") 'Tabelle mit Zieldaten
'Array zur Suche der Quelldaten erstellen
sSuchen = InputBox("Bitte Land eingeben", "Eingabe Suchdaten", "DE")
If sSuchen = "" Then Exit Sub
arr2 = ArrayErstellen(sLand:=sSuchen)
'Daten in Blatt2 einlesen
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With wks1
For Zeile1 = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
For iIndex = LBound(arr2, 2) To UBound(arr2, 2)
'ID in Blatt1 mit ID in Array vergleichen
If .Cells(Zeile1, 1).Value = sSuchen _
And .Cells(Zeile1, 2).Value = arr2(iIndex, 2) Then
'Daten aus Tabelle 2 in Tabelle 1 eintragen
.Cells(Zeile1, 3).Value = wks2.Cells(arr2(iIndex, 3), 4).Value
.Cells(Zeile1, 4).Value = wks2.Cells(arr2(iIndex, 3), 5).Value
Exit For
End If
Next
Next
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
Function ArrayErstellen(sLand As String) As Variant
Dim wks2 As Worksheet
Dim Zeile2 As Long
Dim arr2() As Variant, iIndex As Long
Const SpLand2 As Long = 1 'Spalte mit Land in Blatt 2
Const SpID2 As Long = 2 'Spalte mit ID in Blatt 2
Const Zeile2_1 As Long = 2 '1. Datenzeile in Blatt 2
Set wks2 = Worksheets("Tab2") 'Tabelle mit Quelldaten
With wks2
iIndex = 0
ReDim arr2(1 To Application.WorksheetFunction.CountIf(.Range(.Cells(Zeile2_1, SpLand2), _
.Cells(.Rows.Count, SpLand2)), sLand), 1 To 3)
For Zeile2 = Zeile2_1 To .Cells(.Rows.Count, SpLand2).End(xlUp).Row
If .Cells(Zeile2, SpLand2).Value = sLand Then
iIndex = iIndex + 1
arr2(iIndex, 1) = .Cells(Zeile2, SpLand2).Value 'Land
arr2(iIndex, 2) = .Cells(Zeile2, SpID2).Value 'ID
arr2(iIndex, 3) = Zeile2 'Zeilennummer
End If
Next
End With
ArrayErstellen = arr2
End Function