Makro steigt bei zu vielen Daten aus
21.11.2017 09:59:20
Kai
ich habe hier einmal Hilfe zu meinem Excel Problem erhalten. Es geht darum bestimmte Daten zu kopieren. Dies habe ich in folgendem Thema beschrieben: https://www.herber.de/cgi-bin/callthread.pl?index=1534197
Ausgangssituation:
a b c d e 20% 50% 30%
a d h k r 100%
a d t h j 15% 15% 70%
a g z r e 5% 5% 5% 5% 80%
Gewünschtes Ergebnis:
Ort 2 a b c d e 50%
Ort 4 a b c d e 30%
Ort 1 a d h k r 100%
Ort 1 a d t h j 15%
Ort 2 a d t h j 15%
Ort 5 a d t h j 70%
Ort 1 a g z r e 5%
Ort 2 a g z r e 5%
Ort 3 a g z r e 5%
Ort 4 a g z r e 5%
Ort 5 a g z r e 80%
Dadurch das hierbei alle Daten kopiert werden und nicht nur die die Später benötigt werden, musste ich noch die Daten löschen für die keine Prozentzahl vorliegt. hierfür habe ich auch Hilfe erhalten:
https://www.herber.de/cgi-bin/callthread.pl?index=1534871
Mittlerweile hat sich die Tabelle etwas verändert und wir haben das makro angepasst. Allerdings steigt es bei mehr als ca. 4500 Zeilen aus. Hat jemand evtl. eine Idee wie wir das ändern können?
Ich füge unsere aktuelle Version einmal bei:
Private Sub CommandButton1_Click() 'Start des Makros bei Klick des _
Buttons
With Application
.Calculation = xlCalculationManual 'Berechnung auf manuell
.ScreenUpdating = False 'Bildschirmaktualisierung aus
.EnableEvents = False 'Ereignismakros abschalten
End With
Call alte_Daten_löschen 'Start Makro alte_Daten_löschen
Call Tabelle2.Werte_kopieren 'Start Makro Werte_kopieren
Call Lösche_alle_Zeilen_ohne_Prozentwert 'Start Makro Lö _
sche_alle_Zeilen_ohne_Prozentwert
With Application
.Calculation = xlCalculationAutomatic 'Berechnung auf Automatic
.ScreenUpdating = True 'Bildschirmaktualisierung ein
.EnableEvents = True 'Ereignismakros einschalten
End With
ActiveSheet.Cells(1, 1).Select
End Sub
Sub alte_Daten_löschen()
Range(Rows(2), Rows(Rows.Count)).Delete 'Lösche alle Zeilen mit Inhalt ab Zeile 2
End Sub
Sub Lösche_alle_Zeilen_ohne_Prozentwert()
With Tabelle1.UsedRange
With .Columns(.Columns.Count).Offset(1, 1).Resize(.Rows.Count - 1, 1)
.Formula = "=IF(OR(F2="""",F2=0),TRUE,0)"
.Copy
.PasteSpecial xlPasteValues
.EntireRow.Sort .Cells(1), xlAscending, Header:=False
On Error Resume Next
.SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error GoTo 0
.ClearContents
End With
End With
End Sub
Sub Werte_kopieren() _
'Bezeichnung Makro
Dim R1 As Range _
'Definition der Bereich R1
Dim R2 As Range _
'Definition der Bereich R2
Dim R3 As Range _
'Definition der Bereich R3
Dim R4 As Range _
'Definition der Bereich R4
Dim z As Long _
'Definition der Zeichenlänge von Variable z
Dim t As Long _
'Definition der Zeichenlänge von Variable t
z = Sheets(1).UsedRange.Rows.Count _
'Definition der Variable z Zähle alle Zeilen mit Inhalt des ersten Sheets
lc = Cells(1, Columns.Count).End(xlToLeft).Column _
'Definition der Variable lc Zähle alle Spalten mit Inhalt des ersten Sheets
For t = 2 To z _
'Beginn der Schleife mit Wert 2 bis Wert der gezählten Spalten (Variable z)
Set R1 = Range(Cells(t, 41), Cells(t, 43)) _
'Auswahl des Bereichs der Spalten t,41 bis t,43
Set R4 = Range(Cells(t, 14), Cells(t, 14)) _
'Auswahl des Bereichs der Spalten t,14 bis t,14
Set R2 = Range(Cells(t, 44), Cells(t, lc)) _
'Auswahl des Bereichs der Spalten t,44 bis t,lc
Set R3 = Range(Cells(1, 44), Cells(1, lc)) _
'Auswahl des Bereichs der Spalten 1,44 bis 1,lc
R1.Copy _
'Kopie des zuvor selektierten Bereichs
Sheets(2).Cells(t * (lc - 5) - (lc - 5), 2).Resize(R2.Columns.Count).PasteSpecial _
'Einfügen des Bereichs in Spalte 2
R2.Copy _
'Kopie des zuvor selektierten Bereichs
Sheets(2).Cells(t * (lc - 5) - (lc - 5), 6).PasteSpecial Transpose:=True _
'Einfügen des Bereichs in Spalte 6
R3.Copy _
'Kopie des zuvor selektierten Bereichs
Sheets(2).Cells(t * (lc - 5) - (lc - 5), 1).PasteSpecial Transpose:=True _
'Einfügen des Bereichs transponiert in Spalte 1
R4.Copy _
'Kopie des zuvor selektierten Bereichs
Sheets(2).Cells(t * (lc - 5) - (lc - 5), 5).Resize(R2.Columns.Count).PasteSpecial _
'Einfügen des Bereichs Bereich transponiert in Spalte 5
Next t _
'Schleife Auswahl der nächsten (t+1) bis zur letzten Variable
End Sub _
'Ende des Makros
Bin für jede Hilfe dankbar.
Viele Grüße
Kai