Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1172to1176
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
Inhaltsverzeichnis

Code optimieren

Code optimieren
Charly
Guten Morgen
Folgender Code macht zwar was er soll, ich denke aber das geht auch anders (professioneller).
Ich hoffe ihr könnt mir wieder mal helfen.

Sub Eintragen_Form2()
'Eintragen in Liste 2
Dim LetzteTab As Integer
LetzteTab = ActiveWorkbook.Sheets.Count
Dim ZeileAnfang As Integer
Dim ZeileAnfang2 As Integer
ZeileAnfang = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
ActiveSheet.Range("Q10:Q28").Copy
Sheets("Liste_2").Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues
ActiveSheet.Range("R10:R28").Copy
Sheets("Liste_2").Cells(ZeileAnfang, 2).PasteSpecial Paste:=xlValues
ActiveSheet.Range("A10:A28").Copy
Sheets("Liste_2").Cells(ZeileAnfang, 3).PasteSpecial Paste:=xlValues
ActiveSheet.Range("G10:G28").Copy
Sheets("Liste_2").Cells(ZeileAnfang, 4).PasteSpecial Paste:=xlValues
ActiveSheet.Range("L10:L28").Copy
Sheets("Liste_2").Cells(ZeileAnfang, 5).PasteSpecial Paste:=xlValues
ActiveSheet.Range("K10:K28").Copy
Sheets("Liste_2").Cells(ZeileAnfang, 6).PasteSpecial Paste:=xlValues
'   2. Seite
Sheets(LetzteTab).Activate
ZeileAnfang2 = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
ActiveSheet.Range("Q36:Q58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 1).PasteSpecial Paste:=xlValues
ActiveSheet.Range("R36:R58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 2).PasteSpecial Paste:=xlValues
ActiveSheet.Range("A36:A58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 3).PasteSpecial Paste:=xlValues
ActiveSheet.Range("G36:G58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 4).PasteSpecial Paste:=xlValues
ActiveSheet.Range("L36:L58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 5).PasteSpecial Paste:=xlValues
ActiveSheet.Range("K36:K58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 6).PasteSpecial Paste:=xlValues
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub

Gruss Charly
AW: Code optimieren
29.08.2010 10:13:29
Oberschlumpf
Hi Charly
Ich weiß zwar nicht, ob mein Code professioneller ist, aber so könnte es auch gehen
(ungetestet, weil hab ich ja deine Daten + Datei nicht
und...ich hab den Code wegen keine Testmöglichkeit erst mal nur für den ersten Kopierblock geändert)
Sub Eintragen_Form2()
'Eintragen in Liste 2
Dim LetzteTab As Integer
LetzteTab = ActiveWorkbook.Sheets.Count
Dim ZeileAnfang As Integer
Dim ZeileAnfang2 As Integer
Dim lstrCol As String, liZaehler, liCol As Integer
ZeileAnfang = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
lstrCol = "Q"
liCol = 1
For liZaehler = 1 To 6
ActiveSheet.Range(lstrCol & "10:" & lstrCol & "28").Copy
Sheets("Liste_2").Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues
Select Case liZaehler
Case 1
lstrCol = "R"
liCol = 2
Case 2
lstrCol = "A"
liCol = 3
Case 3
lstrCol = "G"
liCol = 4
Case 4
lstrCol = "L"
liCol = 5
Case 5
lstrCol = "K"
liCol = 6
End Select
Next
'   2. Seite
Sheets(LetzteTab).Activate
ZeileAnfang2 = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
ActiveSheet.Range("Q36:Q58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 1).PasteSpecial Paste:=xlValues
ActiveSheet.Range("R36:R58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 2).PasteSpecial Paste:=xlValues
ActiveSheet.Range("A36:A58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 3).PasteSpecial Paste:=xlValues
ActiveSheet.Range("G36:G58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 4).PasteSpecial Paste:=xlValues
ActiveSheet.Range("L36:L58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 5).PasteSpecial Paste:=xlValues
ActiveSheet.Range("K36:K58").Copy
Sheets("Liste_2").Cells(ZeileAnfang2, 6).PasteSpecial Paste:=xlValues
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub
Hilfts denn?
Dann könntest du ja den Rest anpassen, oder (wenns dir denn gefällt)
Ciao
Thorsten
Anzeige
mist...Korrektur!
29.08.2010 10:19:17
Oberschlumpf
Hi Charly
ändere noch diese Zeile:

Sheets("Liste_2").Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues

um in diese Zeile
Sheets("Liste_2").Cells(ZeileAnfang, liCol).PasteSpecial Paste:=xlValues

Nun müsste es laufen, oder?
Ciao
Thorsten
kein Mist...
29.08.2010 10:35:51
Charly
... ist doch die erste Spalte
Gruss Charly
AW: kein Mist...
29.08.2010 10:39:45
Oberschlumpf
Hi Charly
Ja, im ersten Durchlauf der Schleife ist die 1 noch richtig.
Aber wenn du die 1 nicht durch liCol ersetzt, dann werden die Werte IMMER in 1 - in Spalte 1 - abgelegt.
Gib mir noch n paar Minuten, dann "pack" ich deinen Code in zwei For/Next-Schleifen.
Und dann finde auch ich, dass mein Code ganz vielleicht ein bisschen professionell ist ;-)
Ciao
Thorsten
Anzeige
AW: Code optimieren
29.08.2010 10:28:08
Charly
Hi Thorsten,
es hilft.
Ich brauch nur ne Weile um durchzublicken.
Aber ich hoffe den 2. Teil bekomme ich hin.
Wenn nicht melde ich mich noch mal.
Danke und einen schönen Sonntag noch.
Gruss Charly
AW: Code optimieren
29.08.2010 10:13:58
fcs
Hallo Charly,
viel ist da nicht zu machen, man kann die Struktur etwas übersichtlicher machen indem du die Tabellenblätter Objektvariablen zuweist.
Die Zellbereiche aus Spalten Q und R kann man in einer Anweisung kopieren, da sie im Zielblatt auch in benachbarten Spalten eingefügt werden.
Die Variable Zeilenanfang2 kannst du dir sparen, du kannst hier die Variable Zeilenanfang erneut benutzen.
Gruß
Franz
Sub Eintragen_Form2()
'Eintragen in Liste 2
Dim wks_Aktiv As Worksheet, wks_2 As Worksheet, wks_Letztes As Worksheet
Dim ZeileAnfang As Integer
Set wks_Aktiv = Aktivesheet
Set wks_2 = Worksheets("Liste_2")
Set wks_Letztes = Sheets(ActiveWorkbook.Sheets.Count)
With wks_2
ZeileAnfang = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
wks_Aktiv.Range("Q10:R28").Copy
.Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues
wks_Aktiv.Range("A10:A28").Copy
.Cells(ZeileAnfang, 3).PasteSpecial Paste:=xlValues
wks_Aktiv.Range("G10:G28").Copy
.Cells(ZeileAnfang, 4).PasteSpecial Paste:=xlValues
wks_Aktiv.Range("L10:L28").Copy
.Cells(ZeileAnfang, 5).PasteSpecial Paste:=xlValues
wks_Aktiv.Range("K10:K28").Copy
.Cells(ZeileAnfang, 6).PasteSpecial Paste:=xlValues
'   2. Seite
wks_Letztes.Activate 'für die Funktion des Makros nicht erforderlich
ZeileAnfang = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
wks_Letztes.Range("Q36:R58").Copy
.Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues
wks_Letztes.Range("A36:A58").Copy
.Cells(ZeileAnfang, 3).PasteSpecial Paste:=xlValues
wks_Letztes.Range("G36:G58").Copy
.Cells(ZeileAnfang, 4).PasteSpecial Paste:=xlValues
wks_Letztes.Range("L36:L58").Copy
.Cells(ZeileAnfang, 5).PasteSpecial Paste:=xlValues
wks_Letztes.Range("K36:K58").Copy
.Cells(ZeileAnfang, 6).PasteSpecial Paste:=xlValues
End With
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub

Anzeige
AW: Code optimieren - die Zweite
29.08.2010 10:32:32
fcs
Hallo Charly,
inspiriert von Thorstens Idee, die Bereich in einer Schleife zu kopieren, hier eine Variante, bei der Quellbereiche und Zielspalten in Arrays vorgegeben werden.
Gruß
Franz
Sub Eintragen_Form2()
'Eintragen in Liste 2
Dim wks_Aktiv As Worksheet, wks_2 As Worksheet, wks_Letztes As Worksheet
Dim ZeileAnfang As Integer, arrQuelle, arrZiel, iIndex As Long
Set wks_Aktiv = Aktivesheet
Set wks_2 = Worksheets("Liste_2")
Set wks_Letztes = Sheets(ActiveWorkbook.Sheets.Count)
With wks_2
'Array mit den Nummern der Einfügespalten im Zielblatt (Liste_2)
arrZiel = Array(1, 3, 4, 5, 6)
'Array mit Zellbereichen in Quelle (Aktives Blatt)
arrQuelle = Array("Q10:R28", "A10:A28", "G10:G28", "L10:L28", "K10:K28")
ZeileAnfang = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
For iIndex = LBound(arrQuelle) To UBound(arrQuelle)
wks_Aktiv.Range(arrQuelle(iIndex)).Copy
.Cells(ZeileAnfang, arrZiel(Index)).PasteSpecial Paste:=xlValues
Next
'   2. Seite
wks_Letztes.Activate 'für die Funktion des Makros nicht erforderlich
'Array mit Zellbereichen in Quelle (Letztes Blatt)
arrQuelle = Array("Q36:R58", "A36:A58", "G36:G58", "L36:L58", "K36:K58")
ZeileAnfang = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
For iIndex = LBound(arrQuelle) To UBound(arrQuelle)
wks_Letztes.Range(arrQuelle(iIndex)).Copy
.Cells(ZeileAnfang, arrZiel(Index)).PasteSpecial Paste:=xlValues
Next
End With
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub

Anzeige
AW: Code optimieren - die Dritte
29.08.2010 10:45:44
fcs
Hallo Charly,
hier noch eine Variante.
In der 2. war übrigens noch ein Tippfehler (2 mal muss "Index" durch "iIndex ersetzt werden.
Sub Eintragen_Form2()
'Eintragen in Liste 2
Dim wks_Aktiv As Worksheet, wks_2 As Worksheet, wks_Letztes As Worksheet
Dim ZeileAnfang As Integer, arrQuelle, arrZiel, iIndex As Long
Set wks_Aktiv = Aktivesheet
Set wks_2 = Worksheets("Liste_2")
Set wks_Letztes = Sheets(ActiveWorkbook.Sheets.Count)
With wks_2
'Array mit den Nummern der Einfügespalten im Zielblatt
arrZiel = Array(1, 2, 3, 4, 5, 6) 'A, B, C, D, E, F
'Array mit Nummern der Spalten in der Quelle (Aktives Blatt/Letztes Blatt)
arrQuelle = Array(17, 18, 1, 7, 12, 11) 'Q, R, A, G, L, K
ZeileAnfang = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
For iIndex = LBound(arrQuelle) To UBound(arrQuelle)
With wks_Aktiv
.Range(.Cells(10, arrQuelle(iIndex)), .Cells(28, arrQuelle(iIndex))).Copy
End With
.Cells(ZeileAnfang, arrZiel(iIndex)).PasteSpecial Paste:=xlValues
Next
'   2. Seite
wks_Letztes.Activate 'für die Funktion des Makros nicht erforderlich
ZeileAnfang = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
For iIndex = LBound(arrQuelle) To UBound(arrQuelle)
With wks_Letztes
.Range(.Cells(36, arrQuelle(iIndex)), .Cells(58, arrQuelle(iIndex))).Copy
End With
.Cells(ZeileAnfang, arrZiel(iIndex)).PasteSpecial Paste:=xlValues
Next
End With
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub

Anzeige
AW: Code optimieren - die Zweite
29.08.2010 10:48:46
Charly
Hi Franz,
Klasse.
Erheblicher Geschwindigkeitsvorteil da es noch eine Schleife über viele Blätter gibt.
Ich danke Dir.
Gruss Charly
und hier nun meine 2. Version :)
29.08.2010 10:50:00
Oberschlumpf
Hi
Versuch mal:
Option Explicit
Sub Eintragen_Form2()
'Eintragen in Liste 2
Dim LetzteTab As Integer
LetzteTab = ActiveWorkbook.Sheets.Count
Dim ZeileAnfang As Integer
Dim ZeileAnfang2 As Integer
Dim lstrCol As String, liZaehler, liCol As Integer, liZweimal As Integer, liRow1 As Integer,  _
liRow2 As Integer
ZeileAnfang = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
lstrCol = "Q"
liCol = 1
liRow1 = 10
liRow2 = 28
For liZweimal = 1 To 2
For liZaehler = 1 To 6
ActiveSheet.Range(lstrCol & liRow1 & ":" & lstrCol & liRow2).Copy
Sheets("Liste_2").Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues
Select Case liZaehler
Case 1
lstrCol = "R"
liCol = 2
Case 2
lstrCol = "A"
liCol = 3
Case 3
lstrCol = "G"
liCol = 4
Case 4
lstrCol = "L"
liCol = 5
Case 5
lstrCol = "K"
liCol = 6
End Select
Next
'   2. Seite
ZeileAnfang = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
lstrCol = "Q"
liCol = 1
liRow1 = 36
liRow2 = 58
Sheets(LetzteTab).Activate 'ob diese Zeile sein muss, weiß ich nicht, aber sicher  _
du
Next
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub

So, auch hier ungetestet.
Bin neugierig, obs klappt :-)
Ciao
Thorsten
Anzeige
AW: und hier nun meine 2. Version :)
29.08.2010 11:09:27
Charly
Hi Thorsten,
läuft prima.
Der Vorteil: bei deinem Code blicke ich durch.
Der Nachteil: Franz sein Code ist viel schneller.
Da brauch ich aber ne Weile um das nachvollziehen zu können.
Obwohl er mir alles schön kommentiert hat.
Aber mit Arrays hab ich noch nie was gemacht.
Danke Dir Thorsten
Gruss Charly
AW: und hier nun meine 2. Version :)
29.08.2010 11:10:08
fcs
Hallo Thorsten,
ich würde deinen Vorschlag noch in die folgende Richtung optimieren.
Wirkt etwas übersichtlicher und braucht ein paar Zeilen weniger.
Gruß
Franz
Sub Eintragen_Form2()
'Eintragen in Liste 2
Dim LetzteTab As Integer
LetzteTab = ActiveWorkbook.Sheets.Count
Dim ZeileAnfang As Integer
Dim lstrCol As String, liZaehler, liCol As Integer, liZweimal As Integer, _
liRow1 As Integer, liRow2 As Integer
'Zeilen im aktiven Blatt
liRow1 = 10
liRow2 = 28
For liZweimal = 1 To 2
ZeileAnfang = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
For liZaehler = 1 To 7
Select Case liZaehler
Case 1
lstrCol = "Q"
liCol = 1
Case 2
lstrCol = "R"
liCol = 2
Case 3
lstrCol = "A"
liCol = 3
Case 4
lstrCol = "G"
liCol = 4
Case 5
lstrCol = "L"
liCol = 5
Case 6
lstrCol = "K"
liCol = 6
End Select
ActiveSheet.Range(lstrCol & liRow1 & ":" & lstrCol & liRow2).Copy
Sheets("Liste_2").Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues
Next
'   2. Seite
Sheets(LetzteTab).Activate 'diese Zeile muss, da aus aktivem Blatt kopiert wird
'Zeilen im letzten Blatt
liRow1 = 36
liRow2 = 58
Next
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub

Anzeige
zusammen schaffen wir das schon..irgdwie :)
29.08.2010 11:15:38
Oberschlumpf
Hi Franz
Ja, grundsätzlich haste Recht. Jetzt wird noch weniger Code benötigt.
Abeeeeerrrrrr :-)
Hey Charly, aufgepasst! :-)
In der Korrektur meines Codes von Franz musst du auch wieder diese Zeile
Sheets("Liste_2").Cells(ZeileAnfang, 1).PasteSpecial Paste:=xlValues

umändern in diese Zeile
Sheets("Liste_2").Cells(ZeileAnfang, liCol).PasteSpecial Paste:=xlValues

Weil sonst - wie schon mal - werden wieder alle Werte in Spalte A eingefügt.
Los Charly, antworte...ich will Ergeeebnissseeee...hihi (nur Spaß ;-) )
Ciao
Thorsten
Anzeige
Antwort...
29.08.2010 11:31:51
Charly
... ob Ihr mir glaubt oder nicht, es werden alle Werte korekt eingefügt ohne die Zeile zu ändern.
Ich würde die Datei ja hochladen, aber ich wollte eigentlich noch ein Weilchen in der Firma arbeiten.
Und alle Details durch xxx ersetzen und dann doch noch was vergessen... Ach nö
Ich danke Euch
Gruss Charly
Sorry das ist Blödsinn.. oT.
29.08.2010 11:37:27
Charly
AW: Code optimieren
29.08.2010 13:34:19
Gerd
Hallo Charly,
weil heute Sonntag ist, ebenfalls nich voll getestet:
Sub bb()
Dim arr(1 To 6), arrOut()
Dim sh
Dim intIndex As Integer, i As Integer, j As Integer
sh = Array(ActiveSheet, Sheets(Sheets.Count))
For intIndex = 0 To 1
If intIndex = 0 Then
ReDim arrOut(1 To 19, 1 To 6)
With sh(intIndex)
arr(1) = .Range("Q10:Q28")
arr(2) = .Range("R10:R28")
arr(3) = .Range("A10:A28")
arr(4) = .Range("G10:G28")
arr(5) = .Range("L10:L28")
arr(6) = .Range("K10:K28")
End With
Else
ReDim arrOut(1 To 23, 1 To 6)
With sh(intIndex)
arr(1) = .Range("Q36:Q58")
arr(2) = .Range("R36:R58")
arr(3) = .Range("A36:A58")
arr(4) = .Range("G36:G58")
arr(5) = .Range("L36:L58")
arr(6) = .Range("K36:K58")
End With
End If
For i = 1 To 6
For j = 1 To UBound(arr(1))
arrOut(j, i) = arr(i)(j, 1)
Next
Next
Sheets("Liste").Cells(5000, 3).End(xlUp).Offset(1, -2).Resize(UBound(arrOut, 1), 6) =  _
arrOut
Next
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub
Gruß Gerd
Anzeige
AW: Code optimieren
29.08.2010 14:29:56
Charly
Hi Gerd,
bei deinem Code bekomme ich Laufzeitfehler 9
Das else ist auch nicht ok.
In etwa so:
With sh(intIndex)
arr(1) = .Range("Q10:Q28")
arr(2) = .Range("R10:R28")
arr(3) = .Range("A10:A28")
arr(4) = .Range("G10:G28")
arr(5) = .Range("L10:L28")
arr(6) = .Range("K10:K28")
arr(7) = .Range("Q36:Q58")
arr(8) = .Range("R36:R58")
arr(9) = .Range("A36:A58")
arr(10) = .Range("G36:G58")
arr(11) = .Range("L36:L58")
arr(12) = .Range("K36:K58")
End With
Wie müsste der Code dann lauten?
Vieleicht kannst Du nochmal? Weil Heute Sonntag ist.
Danke
Gruss Charly
AW: Code optimieren
29.08.2010 14:57:55
Gerd
Hallo Charly,
wenn 's noch interessiert.
Ersetze: Sheets("Liste") durch Sheets("Liste_2")
Wegen dem weiteren, müsstest Du den Code zeigen, so wie Du ihn angepasst hast.
Gruß Gerd
Danke Gerd jetzt läufts ... oT.
29.08.2010 15:07:06
Charly
AW: Code optimieren professioneller
29.08.2010 13:38:43
Daniel
Hi
ich würde den Code so schreiben:
Sub test()
Dim SpalteQuelle, SpalteZiel
Dim ZeileQuelle, ZeileNQuelle
Dim ZeileZiel As Long
Dim Blatt
Dim i As Long, sp As Long
SpalteQuelle = Array(17, 18, 1, 7, 12, 11)
SpalteZiel = Array(1, 2, 3, 4, 5, 6)
ZeileQuelle = Array(10, 36)
ZeileNQuelle = Array(17, 23)
Blatt = Array(ActiveSheet.Index, ActiveWorkbook.Sheets.Count)
For i = 0 To UBound(ZeileQuelle)
ZeileZiel = Sheets("Liste_2").Cells(5000, 3).End(xlUp).Row + 1
For sp = 0 To UBound(SpalteQuelle)
Sheets(Blatt(i)).Cells(ZeileQuelle(i), SpalteQuelle(sp)).Resize(ZeileNQuelle(i), 1). _
Copy
Sheets("Liste_2").Cells(ZeileZiel, SpalteZiel(sp)).PasteSpecial xlPasteValues
Next
Next
Call N_S_F 'Formeln in Liste_2 eintragen
End Sub
wenn sich in den Spalten und Zeilen, die kopiert werden sollen was ändert, brauchst du nur den entsprechenden Eintrag im Arrays ändern.
Gruß, Daniel
AW: Code optimieren professioneller
29.08.2010 14:34:05
Charly
Hi Daniel,
läuft tadellos.
Mit den Spalten ändern hast Du recht, aber den Rest muß ich mir mal in Ruhe reinziehen.
Danke und schönen Restsonntag noch.
Gruss Charly

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige