Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1320to1324
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

VBA - Code Optimierung

VBA - Code Optimierung
30.06.2013 13:26:28
Markus
Guten Tag zusammen,
ich habe mir mit meinen bescheidenen VBA Kenntnissen und den vielen hilfreichen Beiträgen aus dem Forum den folgenden Code zusammen gebastelt. Leider habe ich noch ein Problem mit der ersten With-Anweisung. Ansonsten Funktioniert der Code soweit wie er soll. Kann mir vielleicht jemand den Code vereinfachen bzw. optimieren?
Vielen Dank schon mal an alle.
Gruß Markus
Sub kopieren()
With Sheets("Test")
Range("A2:B5000").Select            'Löscht die Einträge von Datenblatt "Overview", soll so  _
aber nicht sein, nur bei Blatt "Test" soll das sein, vielleicht kann man das auch dynamisch machen, ohne Range, nur alle gefüllten Zeilen
Selection.ClearContents
End With
With Sheets("Overview")
.Unprotect Password:="Test"
Dim z As Integer
Dim leer As Integer
Dim Target1 As Range
Dim Target2 As Range
z = 24
Do
If .Cells(z, 4)  "" Then     'Makro soll so lange laufen bis in Spalte 4 kein Eintrag  _
mehr ist
leer = False
Else
leer = True
End If
If .Cells(z, 3).Value = "a" Then    'Wenn in Spalte 3 ein "a" dann sollen der Inhalt aus  _
Spalte 4 und 5 kopiert werden
.Cells(z, 4).Copy
.Cells(z, 5).Copy
' Der Inhalt aus Spalte 4 und 5 sollen in die nächste freie  _
Zelle im Arbeitsblatt "Test" kopiert werden (Spalte 1 und 2)
Set Target1 = Sheets("Test").Range("A65536").End(xlUp).Offset(1, 0)
Sheets("Overview").Cells(z, 4).Copy Destination:=Target1
Set Target2 = Sheets("Test").Range("B65536").End(xlUp).Offset(1, 0)
Sheets("Overview").Cells(z, 5).Copy Destination:=Target2
End If
z = z + 1
Loop Until leer = True
End With
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA - Code Optimierung
30.06.2013 13:39:21
Hajo_Zi

Option Explicit
Sub kopieren()
Sheets("Test").Range("A2:B5000").ClearContents
With Sheets("Overview")
.Unprotect Password:="Test"
Dim z As Integer
Dim leer As Integer
Dim Target1 As Range
Dim Target2 As Range
z = 24
Do
If .Cells(z, 4)  "" Then     'Makro soll so lange laufen bis in Spalte 4 kein  _
Eintrag _
mehr ist
leer = False
Else
leer = True
End If
If .Cells(z, 3).Value = "a" Then    'Wenn in Spalte 3 ein "a" dann sollen der  _
Inhalt aus _
Spalte 4 und 5 kopiert werden
.Cells(z, 4).Copy
.Cells(z, 5).Copy
' Der Inhalt aus Spalte 4 und 5 sollen in die nächste freie _
Zelle im Arbeitsblatt "Test" kopiert werden (Spalte 1 und 2)
Set Target1 = Sheets("Test").Range("A65536").End(xlUp).Offset(1, 0)
.Cells(z, 4).Copy Destination:=Target1
Set Target2 = Sheets("Test").Range("B65536").End(xlUp).Offset(1, 0)
.Cells(z, 5).Copy Destination:=Target2
End If
z = z + 1
Loop Until leer = True
End With
End Sub

Anzeige
AW: VBA - Code Optimierung
30.06.2013 14:29:35
Markus
Danke Hajo,
kann manchmal so einfach sein.
Schönes Wochenende noch.
Gruß Markus

AW: VBA - Code Optimierung
30.06.2013 16:28:05
Hajo_Zi
Hallo Markus,
noch paar sinnlose Zeilen entfernt.
Option Explicit
Sub kopieren()
Sheets("Test").Range("A2:B5000").ClearContents
With Sheets("Overview")
.Unprotect Password:="Test"
Dim z As Long
Dim leer As Integer
Dim Target1 As Range
Dim Target2 As Range
z = 24
Do
leer = .Cells(z, 4)  ""
If .Cells(z, 3).Value = "a" Then    'Wenn in Spalte 3 ein "a" dann sollen der  _
Inhalt aus _
Spalte 4 und 5 kopiert werden HIER WIRD NICHTS KOPIERT
'.Cells(z, 4).Copy
'.Cells(z, 5).Copy
' Der Inhalt aus Spalte 4 und 5 sollen in die nächste freie _
Zelle im Arbeitsblatt "Test" kopiert werden (Spalte 1 und 2)
Set Target1 = Sheets("Test").Range("A65536").End(xlUp).Offset(1, 0)
.Cells(z, 4).Copy Destination:=Target1
Set Target2 = Sheets("Test").Range("B65536").End(xlUp).Offset(1, 0)
.Cells(z, 5).Copy Destination:=Target2
End If
z = z + 1
Loop Until leer = True
.Protect Password:="Test"
End With
End Sub
Gruß Hajo
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige