suche nach einer schnelleren Lösung als die momentan von mir verwendete
Columns(Ranch_Bereich).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Warum, es gibt 20 verschiedene Kriterien und 35 Unterschiedliche Länder.
Nicht in jedem Land treffen alle 20 Kriterien zu sondern nur 1, 3, 5 oder 15 usw. um die zutreffenden Kriterien herauszufiltern setze ich einen Filter auf das LAND, dann kopiere ich mir die alle hier nun zutreffen Kriterien aus einer Spalte in einen Hilfsbereich.
In diesem wende ich nun oben angeführte Funktion ).AdvancedFilter Action:= an um von jedem Kriterium nur mehr einen Eintrag zu haben.
Diese werden dann mit Application.CutCopyMode = False und Selection.Copy in eine weitere Hilfsspalte und von dieser in ein Array kopiert.
Aus diesem erfolgt dann im gleichen LAND die Setzung eines zweiten Filters auf die Werte aus dem Array und somit der Export sortiert nach Land und Kriterium in einen File.
Da also die Anzahl der Datensätze in den einzelnen Ländern sehr unterschiedlich sind, z.B. DEU mit 3.800, FRA od. ITA mit an die 1.000 braucht halt diese Funktion Application.CutCopyMode = False daann etwas sehr lange.
Hätte nun versucht den Ranch_Bereich nur auf den zutreffenden Bereich in der Spalte BM als Ranch_Bereich einzuschränken dies mag aber die Application.CutCopyMode = False wiederum nicht. Da ich zu wenige VBA-Kenntnisse habe meine Frage gibt es dafür eine andere Lösung?
Mit einem DANKE schon im Vorhinein für jeden möglichen LÖSUNGSVORSCHLAG.
Gruß Siegfried
Application.CutCopyMode = False
Selection.Copy
Sheets("GrundDaten").Select
Sheets("GrundDaten").Range("BN1").Value = LandMap
Sheets("GrundDaten").Range("BM2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
:=False, Transpose:=False ' einfügen aller zutreffenden Art des _
Landes
Rem Ranch_Bereich = "BM2:BM" & Trim(Val(Sheets(SelectName).Cells( _
1, 1))) + 1
Rem Worksheets("GrundDaten").Range(Ranch_Bereich).Select
Ranch_Bereich = "BM:BM"
Columns(Ranch_Bereich).Select
Columns(Ranch_Bereich).AdvancedFilter Action:=xlFilterInPlace, _
Unique:=True
Call Start_End_Row(StartRow, EndRow, 65, "2C. App_RUNG2_F5") ' _
65 = GrundDaten Spalte BM
Ranch_Bereich = "BM" & Trim(StartRow) & ":BM" & Trim(EndRow) ' ' _
Spalte wählen und Filtern
Worksheets("Grunddaten").Range(Ranch_Bereich).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("GrundDaten").Range("BN2").Select ' die einzeln _
zutreffendn Art einfügen
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
:=False, Transpose:=False
Call prcAutofilter(ActiveSheet.Name, "2D. App_RUNG2_F5")
Call Start_End_Row(StartRow, EndRow, 66, "2E. App_RUNG2_F5") ' _
In GrundDaten Ergebnis CP_Art in Spalte BN
If StartRow = EndRow Then ' zutreffenden Art-Bereich auswählen _
und Array erstellen
Ranch_Bereich = "BN2:BN" & Trim(EndRow) + 1
Worksheets("Grunddaten").Select
AR = Range(Ranch_Bereich) ' aus GrundDaten die einzeln _
zutreffende Art einfügen
Else
Ranch_Bereich = "BN2:BN" + Trim(EndRow)
Worksheets("Grunddaten").Select
AR = Range(Ranch_Bereich) ' aus GrundDaten die einzeln _
zutreffende Art einfügen
End If
Rem =*=*=*=*=*=*
SuchArt = AR 'Array in einen neuen Namen kopieren
L_SuchArt = UBound(SuchArt) ' Länge ds Array auslesen