Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 23:47:55
Datum ausweisen, wenn definierte Summe erreicht ist
25.04.2024 21:40:53
Excel Datenquelle aus dem Web mit Anmeldung?
25.04.2024 21:21:16
Zellkommentar in UserForm anzeigen und bearbeiten
25.04.2024 21:13:13
Kalenderwochen addieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1464to1468
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1464to1468
1464to1468
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Macro schöner oder schneller machen

Macro schöner oder schneller machen
28.12.2015 01:41:32
Thomas
Hallo Excelfreunde,
ich habe mir mal das Macro zusammengestrickt. Es funktioniert eigentlich auch.
Aber ich wollte mal fragen ob man es auch schöner oder schneller darstellen kann.
Es soll die spalten h,k,D,b,z und cn (ohne formeln aber mit allen formaten )kopieren und anschließend sollen nur die spalten von A:F nach Spalte A ( hat überschrift) aufsteigend sortiert werden.
Und als letztes sollen alle zeilen gelöscht werden in denen in der Spalte 3 der wert grösser ist als 1. ( Ich glaub das dauert am längsten).
Muss mann alle schritte nacheinander so machen? Oder kann man das mit den Werte -Formaten einfügen und das sortieren in einem Schritt ( im Speicher) erledigen?
Eventuell geht das ja mit dem bedingten zeilen löschen anders?
liebe grüsse thomas
Option Explicit
Sub AAA_nur_Spalten_kopieren()
On Error GoTo ErrExit
Application.DisplayAlerts = False
Sheets("temp").Columns("a:F").Clear
Sheets("Vorgang").Columns("h").Copy
Sheets("temp").Columns("A").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("A").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("k").Copy
Sheets("temp").Columns("B").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("B").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("D").Copy
Sheets("temp").Columns("C").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("C").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("B").Copy
Sheets("temp").Columns("D").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("D").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Application.CutCopyMode = False
Sheets("Vorgang").Columns("Z").Copy
Sheets("temp").Columns("E").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("E").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("CN").Copy
Sheets("temp").Columns("F").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("F").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
'############ ab hier sortieren mit recorder
ActiveWorkbook.Worksheets("temp").Columns("A:F").Select
ActiveWorkbook.Worksheets("temp").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("temp").Sort.SortFields.Add Key:=Columns( _
"A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("temp").Sort
.SetRange Columns("A:F")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2").Select
Application.DisplayAlerts = True
' alle Zeilen löschen wenn wert in spalte 3 grösser als 1 ist
Dim LoLetzte As Long
Dim LoI As Long
Dim RaZeile As Range
LoLetzte = IIf(IsEmpty(Range("a65536")), Range("a65536").End(xlUp).Row, 65535) ' in B muss  _
ein Wert stehen bei veränderung 65535 anpassen spaltenanzahl
'' !!!!!!!! in spalte 1 muss ein Wert stehen
If LoLetzte 
Sub     ' was passiert hier?
' = LoLetzte To 2  beginne Zeile 2
For LoI = LoLetzte To 2 Step -1
' 1 Then
'  If Cells(LoI, 2 bedeutet in der 2. spalte
If RaZeile Is Nothing Then
Set RaZeile = Rows(LoI)
Else
Set RaZeile = Union(RaZeile, Rows(LoI))
End If
End If
Next LoI
If Not RaZeile Is Nothing Then RaZeile.Delete
Set RaZeile = Nothing
Application.CutCopyMode = False
ErrExit:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "Fehler im Modul Spalten'" & vbLf & String(60, "_") _
& vbLf & vbLf & _
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
_
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation +  _
_
vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - daten"
.Clear
End If
End With
On Error GoTo 0
End Sub

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Macro schöner oder schneller machen
28.12.2015 09:23:41
Sepp
Hallo Thomas,
' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub AAA_nur_Spalten_kopieren()
Dim rng As Range
Dim lngLast As Long, lngR As Long
Dim CalculationMode As Long

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

With Sheets("temp")
  .Columns("A:F").Clear
  
  Sheets("Vorgang").Columns("H").Copy
  .Range("A1").PasteSpecial Paste:=xlValues
  .Range("A1").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
  
  Sheets("Vorgang").Columns("K").Copy
  .Range("B1").PasteSpecial Paste:=xlValues
  .Range("B1").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
  
  Sheets("Vorgang").Columns("D").Copy
  .Range("C1").PasteSpecial Paste:=xlValues
  .Range("C1").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
  
  Sheets("Vorgang").Columns("B").Copy
  .Range("D1").PasteSpecial Paste:=xlValues
  .Range("D1").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
  
  Sheets("Vorgang").Columns("Z").Copy
  .Range("E1").PasteSpecial Paste:=xlValues
  .Range("E1").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
  
  Sheets("Vorgang").Columns("CN").Copy
  .Range("F1").PasteSpecial Paste:=xlValues
  .Range("F1").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
  
  .Columns("A:F").Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending, Header:=xlGuess
  
  ' alle Zeilen löschen wenn wert in spalte 3 grösser als 1 ist
  '##################################################################################
  
  lngLast = Application.Max(2, .Cells(.Rows.Count, 3).End(xlUp).Row)
  
  For lngR = 2 To lngLast
    If .Cells(lngR, 3) > 1 Then
      If rng Is Nothing Then
        Set rng = .Cells(lngR, 3)
      Else
        Set rng = Union(rng, .Cells(lngR, 3))
      End If
    End If
  Next
  
  If Not rng Is Nothing Then
    rng.EntireRow.Delete
  End If
End With

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'AAA_nur_Spalten_kopieren'" & vbLf & String(25, "—") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, 81968, "VBA - Fehler in Prozedur - AAA_nur_Spalten_kopieren", .HelpFile, .HelpContext
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .CutCopyMode = False
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

Set rng = Nothing
End Sub

Gruß Sepp

Anzeige
besten dank an Sepp
28.12.2015 10:31:01
Thomas
Hallo Sepp,
vielen dank für deine Veränderungen.
Nur diese zeile wollte nicht so ( sorteigenschaft konnte nicht zugeordnet werden)
.Columns("A:F").Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending, Header:=xlGuess
habe ein wenig rum gespielt und jetzt sieht sie so aus.
Columns("A:F").Sort key1:=Range("a2"), order1:=xlAscending, Header:=xlYes
Deine Veränderungen machen das Makro ein drittel schneller und sieht auch viel geordneter aus.
besten dank dafür
liebe grüsse thomas

AW: Macro schöner oder schneller machen
28.12.2015 11:22:37
Herbert
Hallo Thomas,
so könnte es noch schöner (sprich kürzer) sein, probiers mal:
Sub AAA_nur_Spalten_kopierenORI()
Dim rng As Range, lngLast As Long, lngR As Long, CalculationMode As Long, arrA, a%
On Error GoTo ErrorHandler
arrA = Array("", "H", "K", "D", "B", "Z", "CN")
Application.ScreenUpdating = False
Application.EnableEvents = False
With Sheets("temp")
.Columns("A:F").Clear
For a = 1 To 6
Sheets("Vorgang").Columns(arrA(a)).Copy
.Range(.Cells(1, a), .Cells(1, a)).PasteSpecial Paste:=xlValues
.Range(.Cells(1, a), .Cells(1, a)).PasteSpecial Paste:=xlPasteFormats 'Formate  _
einfuegen
Next a
.Columns("A:F").Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending, Header:= _
xlGuess
'* alle Zeilen löschen wenn wert in spalte 3 grösser als 1 ist
lngLast = Application.Max(2, .Cells(.Rows.Count, 3).End(xlUp).Row)
For lngR = 2 To lngLast
If .Cells(lngR, 3) > 1 Then
If rng Is Nothing Then
Set rng = .Cells(lngR, 3)
Else
Set rng = Union(rng, .Cells(lngR, 3))
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
ErrorHandler:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'AAA_nur_Spalten_kopieren'" & vbLf & String( _
25, "—") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, 81968, "VBA - Fehler in Prozedur - AAA_nur_Spalten_kopieren", . _
HelpFile, .HelpContext
.Clear
End If
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
On Error GoTo 0
Set rng = Nothing
End Sub
Servus

Anzeige
AW: Macro schöner oder schneller machen
28.12.2015 11:35:11
Daniel
Hi
probiers mal so.
das kopieren wird dadurch optimiert, dass erstmal alles kopiert wird und dann in einem zweiten Schritt die Spalten in Reihenfolge gebracht werden.
zum Sortieren nimmt man in VBA besser die alte Notierung bis Excel 2003.
zum Löschen von Zeilen mit Bedingung ist das Duplikateentfernen die effetivste Methode.
hierzu kennzeichnet man zuerst per Formel alle zu löschenden Zeilen und wendet dann diese Funktion an:
Sub test()
'--- Kopieren
Sheets("Vorgang").Range("B:B,D:D,H:H,K:K,Z:Z,CN:CN").Copy
With Sheets("temp")
'--- als Wert mit Format einfügen
.Cells(1, 1).PasteSpecial xlPasteValues
.Cells(1, 1).PasteSpecial xlPasteFormats
'--- Spalten in Reihenfolge bringen
.Columns(2).Cut
.Columns(1).Insert
.Columns(3).Resize(, 2).Cut
.Columns(1).Insert
'--- sortieren
.Range("A:F").Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
'--- löschen , wenn Spalte 3 grösser 1
With .UsedRange.Columns(.UsedRange.Columns.Count + 1)
.FormulaR1C1 = "=IF(RC3>1,0,Row())"
.Cells(1, 1).Value = 0
.EntireRow.RemoveDuplicates .Column, xlNo
.ClearContents
End With
End With
End Sub
Gruß Daniel

Anzeige
Daniel Sepp und Herbert
29.12.2015 00:36:17
Thomas
Hallo Excelfreunde,
ich habe alle eure Vorschläge getestet und ein wenig zusammengewürfelt.
Was soll ich sagen eine Kombination von euch allen hat sich als schnellste variante erwiesen.
Das langsamste ist die Prozedur Zeilen löschen. hier hat Sepp seine Version die Nase vorn aber nur dann wenn man die Daten vorher sortieren kann. Kann man es nicht sortieren hat die Version von von daniel die nase ein klein wenig vorn.
Aber was soll ich sagen Ihr habt das macro von ursprünglich 45 Sekunden auf 1,5 Sekunden runterbekommen. Da bin ich nur sprachlos.
habt vielen vielen dank für eure mithilfe ich werde mir auf jedenfall alle drei Versionen wegpacken.
liebe grüsse thomas
Sub schnellster_Spalten_kopieren()
Dim rng As Range, lngLast As Long, lngR As Long, CalculationMode As Long, arrA, a%
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
'.Calculation = xlManual
.DisplayAlerts = False
End With
On Error GoTo ErrorHandler
Dim ws As Worksheet
Dim bExists As Boolean
' Alle vorhandenen Arbeitsblätter durchlaufen
For Each ws In Worksheets
If ws.Name = "temp" Then
bExists = True: Exit For
End If
Next
arrA = Array("", "H", "K", "D", "B", "Z", "CN")
Application.ScreenUpdating = False
Application.EnableEvents = False
With Sheets("temp")
.Columns("A:F").Clear
For a = 1 To 6
Sheets("Vorgang").Columns(arrA(a)).Copy
.Range(.Cells(1, a), .Cells(1, a)).PasteSpecial Paste:=xlValues
.Range(.Cells(1, a), .Cells(1, a)).PasteSpecial Paste:=xlPasteFormats 'Formate _
einfuegen
Next a
End With
With Sheets("temp")
' MsgBox ActiveWorkbook.ActiveSheet.Name '  aktives blatt ermitteln
Columns("A:F").Sort key1:=Range("c1"), order1:=xlAscending, Header:=xlGuess
'* alle Zeilen löschen wenn wert in spalte 3 grösser als 1 ist
lngLast = Application.Max(2, .Cells(.Rows.Count, 3).End(xlUp).Row)
For lngR = 2 To lngLast
If .Cells(lngR, 3) > 1 Then
If rng Is Nothing Then
Set rng = .Cells(lngR, 3)
Else
Set rng = Union(rng, .Cells(lngR, 3))
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
Columns("A:F").Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlGuess
ErrorHandler:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'AAA_nur_Spalten_kopieren'" & vbLf & String( _
_
25, "—") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, 81968, "VBA - Fehler in Prozedur - AAA_nur_Spalten_kopieren", . _
_
HelpFile, .HelpContext
.Clear
End If
End With
On Error GoTo 0
With Application
.CutCopyMode = False
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
Set rng = Nothing
End Sub

Anzeige
Gerne geschehen! owt
29.12.2015 09:12:13
Herbert
,,

Daniel habe noch eine bitte
29.12.2015 01:37:42
Thomas
hallo Daniel,
habe noch eine frage bist Du so lieb und schreibst mir mal noch was deine idee in den zeilen macht? ( bzw. berichtigst mich). Wenn man die daten nicht sortieren kann ist diese idee die schnellste von der ich jemals gelesen hab deshalb würde ich es gern verstehen.
With .UsedRange.Columns(.UsedRange.Columns.Count + 1) ' ist klar bereich bestimmen
.FormulaR1C1 = "=IF(RC3>1,0,Row())" ' hier habe ich kein schimmer was heist FormulaR1C1 ( kenne ich von schreibweise irgendwie von formeln? und was ist das RC3
.Cells(1, 1).Value = 0 ' setze alle zeile 1 und spalte a auf null? bitte nicht lachen ist bestimmt Blödsinn
.EntireRow.RemoveDuplicates .Column, xlNo ' setze Bereich auf doppelt wenn nein ist das richtig?
.ClearContents ' doppelte löschen ?
End With
wie würdest Du es schreiben wenn in spalte A ab zeile 2 datum-werte ( datum'se wollte ich nicht schreiben) stehen und es sollen alle zeilen gelöscht werden die älter sind als das aktuelle datum.
vorab schon mal besten dank von mir
liebe grüsse thomas

Anzeige
AW: Daniel habe noch eine bitte
29.12.2015 10:37:35
Daniel
Hi
Das Funktionsprinzip ist einfach:
Ich schreibe in einer Hilfsspalte am Tabellenende eine Formel hin, welche im den Zeilen die gelöscht werden sollen die 0 als Ergebnis hat und in denen die stehen bleiben müssen die aktuelle Zeilennummer.
Damit steht in den zu löschen den Zeilen der gleiche Wert und ich kann diese Zeilen mit der Menüfunktion Daten - Datentools Duplikate entfernen löschen.
Da diese Funktion aber nicht alle Zeilen mit 0 löscht sondern die erste stehen lässt, sorge ich dafür, dass die erste Zeile mit 0 eine Zeile ist die stehen bleiben muss, nämlich die Überschrift.
Das ClearContents am Schluss räumt die Hilfsspalte wieder auf.
Um die Formel in die Zelle zu schreiben verwende ich die R1C1-Schreibweise für Zellbezüge.
Nach dem R kommt die Zeilen- und nach dem C die Spaltennummer (wie Z1S1 in deutsch).
Diese Schreibweise hat gegenüber der üblichen A1-Schreibweise den Vorteil, dass sich relative Zellbezüge besser beschreiben lassen.
Ausserdem zeichnet der Recorder in der R1C1-Schreibweise auf, so dass es dir nicht schwer fallen sollte selbst den benötigten Code für deine neue Problemstellung zu ermitteln.
Gruß Daniel

Anzeige
besten dank an Daniel
29.12.2015 11:12:33
Thomas
Hallo Daniel,
hab vielen dank für die super Erklärung.
Ich kann mir jetzt ein gutes Bild davon machen und nicht nur abschreiben sondern auch verstehen.
liebe grüsse thomas

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige