Hallo
Danke allen für die Hilfe.
Ich kann schon etwas mehr Code zeigen. Im Prinzip geht es um folgendes: Ich bekomme eine Exporttabelle mit ca 50'000 bis 500'000 Zeilen. Die Header sind bekannt und etwas mehr als die die ich dann abhole. Die Reihenfolge ist nicht wichtig.
Nun habe ich 3 Schlaufen:
1. In einer internen Schlaufe habe ich unterschiedliche Bedingungen definiert. In einem Fall lese ich den eigenen Header aus und wechsle zum ExportSheet und suche dort in einer
2. externen Schlaufe einen Header, der dem internen entspricht (sofern er nicht leer, "o", "x", "y" oder "z" entspricht). Sobald ich den gefunden habe, kopiere ich alle Zellen dieser Spalte und verlasse die externe Schlaufe. Im Zielfile füge ich die Kolonne ein.
3. In gewissen Spalten ( "x", "y" oder "z") berechne ich Hilfseinträge und in einer Spalte (bei Case "z") bereite ich die Eingabe für den User vor. Dort muss ich alle Zeile durchgehen und dann die Zellen formatieren oder mit einer Formel füllen. Diese 3. Schlaufe hat mir nun Probleme bereitet, da sie für jede Zelle eine Berechnung oder Bedingung definieren muss. Mit 500'000 Zeilen dauert das schon eine Weile. Daher bin ich auf das Array ausgewichen, das dann als Ganzes eingefügt wird. Einzelne Zellen (die jeweils "erste" Zeile eines Artikels) sollen dem User die Möglichkeit geben, aus einer vordefinierten (zweisprachigen) Liste einen Eintrag zu machen, den ich dann auf alle Zeilen dieses Artikels übertrage und die Zelle entsperre. Die Lösung mit der Zelle entsperren habe ich noch nicht gefunden
Der Code (Auszug) sieht folgendermassen aus:
Code:
Sub InhaltTabelleAbholen1()
Dim ErsteZeile As Integer 'Die erste Zeile mit Daten (ohne Header)
Dim AnzZeilen As Long 'Anzahl Zeilen des entspr. registers mit Daten (muss long sein)
Dim LetzteZeile As Long 'Die Letzte Zeile mit Daten in einem Bereich (muss long sein)
Dim LetzteSpalte As Integer 'Die Letzte Spalte mit Daten (nur in STAO verwendet)
Dim SpalteFZ As Integer 'Die Spalte mit den Fallzahlen im Sheet STAO
Dim HeadExt(1 To 65) As String 'Aktuelle Spaltenheader im Externen Register
Dim HeadInt(1 To 65) As String 'Aktuelle Spaltenheader im Internen Register
Dim FormelLKP As String 'Formelals String für Verweise auf LKPs
Dim FormelCalc As String 'Formel als String für direkte Berechnung
Dim FormelDRP As String 'Formel als String für Wiederholung der DropDown
Dim i As Long 'Schlaufenzähler
Dim i2 As Long 'Schlaufenzählerhalter
Dim vx(1 To 999000, 1 To 1) As Variant 'Array für Formelvorbereitung
'*****************************
ErsteZeile = 10 'Erste Zeile im Datenregister STAO setzen
......
'*Namen der Header auslesen im internen File und zugehörige Werte Kopieren
'*************************************************************************
Application.ScreenUpdating = False
'Spalte für Spalte kopieren (für alle RegType)
For intK = 1 To 65 'Interne Schlaufe setzen
'Header auslesen (muss gleich lauten wie im Exportfile, Position spielt keine Rolle)
HeadInt(intK) = Workbooks(ZielFile).Worksheets(RegInt).Cells(1, intK).Value
Select Case HeadInt(intK) 'Erste unterschiedliche Behandlung je nach Header (x, y, z)
'************************
Case ""
Exit For 'Interne Schlaufe abbrechen wenn leer (am Schluss)
Case "o"
'du nösing 'Nichts abholen und interne Schlaufe weiter schalten
Case "x" 'Verweis-Formel
'******************* '**************
Windows(ZielFile).Activate 'zurück zum Hauptfile, wenn nicht schon da
Worksheets(RegInt).Select 'Register wählen (hier STAO)
Cells(2, intK).Select 'Formelfeld anwählen
FormelLKP = Cells(2, intK).Formula 'Formel zu Spalte auslesen (muss Bezug auf ErsteZeile haben)
With Range(Cells(ErsteZeile, intK), Cells(AnzZeilen + ErsteZeile - 2, intK))
.Formula = FormelLKP 'trägt die Formeln ein
.Formula = .Value 'ersetzt die Formeln durch Werte
End With
Case "y" 'Berechnungs-Formel
'***************** '*****************
Windows(ZielFile).Activate 'zurück zum Hauptfile
Worksheets(RegInt).Select 'Register wählen (hier STAO)
Cells(2, intK).Select 'Formelfeld anwählen
FormelLKP = Cells(2, intK).Formula 'Formel zu Spalte auslesen (muss Bezug auf ErsteZeile haben)
With Range(Cells(ErsteZeile, intK), Cells(AnzZeilen + ErsteZeile - 2, intK))
.Formula = FormelLKP 'trägt die Formeln ein
.Formula = .Value 'ersetzt die Formeln durch Werte
End With
Case "z" 'DropDown mit Auswahlliste
'***************** '*****************
Application.Calculation = xlCalculationManual
Windows(ZielFile).Activate 'zurück zum Hauptfile
Worksheets(RegInt).Select 'Register wählen (hier STAO)
ActiveSheet.Cells(2, intK).Copy 'Formelfeld anwählen und Zelle (mit Dropdown) kopieren
With Range(Cells(ErsteZeile, intK), Cells(AnzZeilen + ErsteZeile - 2, intK))
.PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False 'Auf alle Zeilen einsetzen
.ClearContents 'Allenfalls Inhalt löschen
End With
For i = ErsteZeile To AnzZeilen + ErsteZeile - 2
If ActiveSheet.Cells(i, SpalteFZ).Value = 1 Then 'Wenn FZ = 1 (in Spalte AP)
i2 = i 'Erste Zeile des Falls merken
'**************************************************************************
'Dieser Color Index oder Lock False verlangsamt die ganze Routine 1000 fach!
'With ActiveSheet.Cells(i, intK) 'Erste Zeile eines Falles in Spalte intK
' .Interior.ColorIndex = 19 'hellgelb einfärben
' .Locked = False 'und entsperren
'End With
'**************************************************************************
Else
FormelDRP = "=$BG$" & i2 'Formel zusammensetzen und
vx(1 + i - ErsteZeile, 1) = FormelDRP 'in Array eintragen
End If
Next i
With ActiveSheet
.Range(.Cells(ErsteZeile, intK), _
.Cells(AnzZeilen + ErsteZeile - 2, intK)) _
= vx 'Gesammeltes Array in Kolonne eintragen
End With
Application.Calculation = xlCalculationAutomatic
Case Else 'Andernfalls (wenn Header eine Variable ist)
'*Zum Quellfile und entspr. Register wechseln
Workbooks(QuellFile).Worksheets(RegExt).Activate
For extK = 1 To 65 'Externe Schlaufe setzen (alle Headers durchsuchen)
'********************************************
With Workbooks(QuellFile).Worksheets(RegExt)
If .Cells(1, extK).Value = HeadInt(intK) Then
.Range(Cells(2, extK), Cells(AnzZeilen, extK)).Copy
Exit For 'Externe Schlaufe abbrechen wenn gefunden
End If
End With
Next extK 'Ende der externen Schlaufe
'*********************************************
Windows(ZielFile).Activate 'zurück zum Hauptfile
Worksheets(RegInt).Select 'Register wählen (hier STAO)
ActiveSheet.Cells(ErsteZeile, intK).Select 'Zelle unterhalb entspr. Header anwählen
Selection.PasteSpecial _
Paste:=xlValues, SkipBlanks:=False, _
Transpose:=False 'Daten einfügen (nur Werte)
Application.CutCopyMode = False 'Copyrahmen Ameisen abschalten
End Select 'Ende der Behandlung der Header
'************************
Next intK 'Ende der internen Schlaufe
Application.ScreenUpdating = True
.....
Exit Sub
'-------------------------------------------
Fehler1:
MsgBox "Die Datei mit dem angegeben Namen " & QuellFile & "konnte nicht gefunden werden!"
End Sub
Viele Grüsse
R0dl0f