Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1912to1916
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

Auto Fill Range anpassen

Auto Fill Range anpassen
09.01.2023 12:33:34
Gül
Hallo zusammen,
Ich habe ein simples Makro aufgenommen und es funktioniert eigentlich alles, mein Problem ist lediglich dass ich dieses Makro an verschiedene Listen anwenden werde.
Sprich die "Range:kann auch mal weiter als G64979 gehen, zum Beispiel bis G120000.
Wie muss ich deshalb dieses Makro anpassen, dass Excel so weit ausfüllt bis zum letzten Eintrag?:

Sub TelebalanceTest5()
' TelebalanceTest5 Makro
Rows("1:14").Select
Range("H1").Activate
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$G$64979").AutoFilter Field:=3, Criteria1:=Array( _
"1", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "2", "20", "21", "22", "23", _
"24", "25", "26", "27", "28", "29", "3", "30", "31", "32", "33", "34", "35", "36", "37", "38", _
"39", "4", "40", "41", "42", "5", "6", "7", "8", "9"), Operator:=xlFilterValues
Cells.Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Range("B1").Select
ActiveCell.FormulaR1C1 = "Uhrzeit"
Rows("1:1").Select
Selection.AutoFilter
Columns("B:B").Select
Selection.NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
Range("A1").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("A:A").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("C:C").ColumnWidth = 18.57
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Range("E1").Select
ActiveCell.FormulaR1C1 = "Desktop"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Phone"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Tablet"
Range("F2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-2]/100*RC[2]"
Range("G2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-3]/100*RC[2]"
Range("E2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[1]-RC[2]"
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E63539")
Range("E2:E63539").Select
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F63539")
Range("F2:F63539").Select
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G63539")
Range("G2:G63539").Select
Columns("G:G").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("F:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("H:L").Select
Selection.Delete Shift:=xlToLeft
Sheets("Tabelle1").Select
Sheets("Tabelle1").Name = "07.01.23"
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Range("B10").Select
Sheets("1 Telebalance FTP").Select
ActiveWindow.SelectedSheets.Delete
Range("I12").Select
ActiveWorkbook.Save
Columns("E:G").Select
End Sub

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Auto Fill Range anpassen
09.01.2023 12:55:47
Piet
Hallo
ein ellenlanger Code mit vielen Select. Das kannst du alles rausschmeissen!
Select und dahinter Copy oder Formula kannst du immer in eine Zeile zusammenfassen.
Probiere den von mir berichtigten Code bitte zuerst in einer Testdatei aus, NICHT im Original!

mfg Piet
  • 
    Sub TelebalanceTest5()
    Dim lz1 As Long   'LastZelle in Spalte A ermitteln
    lz1 = Cells(Rows.Count, 1).End(xlUp).Row
    ' TelebalanceTest5 Makro
    Rows("1:14").Delete Shift:=xlUp
    Columns("A").Delete Shift:=xlToLeft
    Columns("C").Delete Shift:=xlToLeft
    Rows("1:1").AutoFilter
    ActiveSheet.Range("$A$1:$G$" & lz1).AutoFilter Field:=3, Criteria1:=Array( _
    "1", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "2", "20", "21", "22", "23", _
    "24", "25", "26", "27", "28", "29", "3", "30", "31", "32", "33", "34", "35", "36", "37", "38", _
    "39", "4", "40", "41", "42", "5", "6", "7", "8", "9"), Operator:=xlFilterValues
    Cells.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("C").Delete Shift:=xlToLeft
    Range("B1").Value = "Uhrzeit"
    Rows("1:1").AutoFilter
    Columns("B").NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    Range("A1").NumberFormat = "m/d/yyyy"
    Columns("A:F").EntireColumn.AutoFit
    Columns("C:C").ColumnWidth = 18.57  '? richtig
    ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort.SortFields.Add2 Key:= _
    Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
    With ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    Columns("E").Select
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Range("E1") = "Desktop"
    Range("F1") = "Phone"
    Range("G1") = "Tablet"
    Range("F2").FormulaR1C1 = "=RC[-2]/100*RC[2]"
    Range("G2").FormulaR1C1 = "=RC[-3]/100*RC[2]"
    Range("E2").FormulaR1C1 = "=RC[-1]-RC[1]-RC[2]"
    Range("E2").AutoFill Destination:=Range("E2:E63539")
    Range("F2").AutoFill Destination:=Range("F2:F63539")
    Range("G2").AutoFill Destination:=Range("G2:G63539")
    Columns("G").Copy
    Columns("G").PasteSpecial Paste:=xlPasteValues
    'ActiveSheet.Paste   '?
    Columns("F").Copy
    Columns("F").PasteSpecial Paste:=xlPasteValues
    'ActiveSheet.Paste
    Columns("E").Copy
    Columns("E").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Columns("H:L").Delete Shift:=xlToLeft
    Sheets("Tabelle1").Select
    Sheets("Tabelle1").Name = "07.01.23"
    Columns("A").NumberFormat = "m/d/yyyy"
    Sheets("1 Telebalance FTP").Delete
    ActiveWorkbook.Save
    'Columns("E:G").Select
    End Sub
    

  • Anzeige
    AW: Auto Fill Range anpassen
    09.01.2023 13:00:17
    Piet
    amüsant, ich sehe gerade Gül = die Rose oder das lachen (gülmek)
    Grüsse aus Ankara an die Heimat
    AW: Auto Fill Range anpassen
    09.01.2023 13:32:31
    UweD
    Hallo
    Auch wenn Piet schon gepostet hat. hier mein Vorschlag


    Auf Select und Aktivate kann zu 99% verzichtet werden.
    Ich hoffe, ich habe alles richtig verkürzt. Wenn nicht, dann erkennst du aber wie es gemacht wird..
    
    Sub TelebalanceTest5()
    ' TelebalanceTest5 Makro
    Dim LR As Long
    Dim TB1 As Worksheet, TB2 As Worksheet
    Set TB1 = Sheets("Tabelle1") ' ggf anpassen
    With TB1
    If TB1.AutoFilterMode Then TB1.AutoFilterMode = False ' Autofilter ausschalten
    LR = .Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
    .Rows("1:14").Delete Shift:=xlUp
    .Columns("A:A").Delete Shift:=xlToLeft
    .Columns("C:C").Delete Shift:=xlToLeft
    .Rows("1:1").AutoFilter
    .Range("$A$1:$G$" & LR).AutoFilter Field:=3, Criteria1:=Array( _
    "1", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "2", "20", "21", "22", "23", _
    "24", "25", "26", "27", "28", "29", "3", "30", "31", "32", "33", "34", "35", "36", "37", "38", _
    "39", "4", "40", "41", "42", "5", "6", "7", "8", "9"), Operator:=xlFilterValues
    .Cells.Copy
    Sheets.Add After:=ActiveSheet
    End With
    Set TB2 = ActiveSheet 'das Neue
    With TB2
    .Paste
    Application.CutCopyMode = False
    .Columns("B:C").Insert Shift:=xlToRight
    .Columns("A:A").TextToColumns Destination:=TB2.Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    .Columns("C:C").Delete Shift:=xlToLeft
    .Range("B1").FormulaR1C1 = "Uhrzeit"
    .Rows("1:1").AutoFilter
    .Columns("B:B").NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    .Range("A1").NumberFormat = "m/d/yyyy"
    .Columns("A:A").EntireColumn.AutoFit
    .Columns("C:C").ColumnWidth = 18.57
    .Columns("D:F").EntireColumn.AutoFit
    With .AutoFilter.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=TB2.Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    .Columns("E:G").Insert Shift:=xlToRight
    .Range("E1") = "Desktop"
    .Range("F1") = "Phone"
    .Range("G1") = "Tablet"
    .Range("F2:F" & LR).FormulaR1C1 = "=RC[-2]/100*RC[2]"
    .Range("G2:G" & LR).FormulaR1C1 = "=RC[-3]/100*RC[2]"
    .Range("E2:E" & LR).FormulaR1C1 = "=RC[-1]-RC[1]-RC[2]"
    .Range("E2:G" & LR).Value = .Range("e2:G" & LR).Value 'Formel in Wert
    .Columns("H:L").Delete Shift:=xlToLeft
    End With
    With TB1
    .Name = Format(Date, "DD.MM.YY")
    .Columns("A:A").NumberFormat = "m/d/yyyy"
    End With
    Application.DisplayAlerts = False 'ohne Nachfragen löschen
    Sheets("1 Telebalance FTP").Delete
    Application.DisplayAlerts = True
    Range("I12").Select
    ActiveWorkbook.Save
    Columns("E:G").Select
    End Sub
    
    LG UweD
    Anzeige
    AW: Auto Fill Range anpassen
    11.01.2023 09:37:11
    Gül
    Guten Morgen und vielen lieben Dank für eure Antworten und schöne Grüße nach Ankara!! :)
    Eure Lösungen waren alle sehr hilfreich und habe alle zu implementieren versucht.
    Ich habe nun folgendes Makro ein bisschen bearbeitet, aber dennoch klappt es nicht ganz.
    
    Sub TelebalanceFERTIGFERTIG()
    ' TelebalanceTest5 Makro
    Dim LR As Long
    Dim TB1 As Worksheet, TB2 As Worksheet
    Set TB1 = Sheets("1 Telebalance FTP") ' ggf anpassen
    With TB1
    If TB1.AutoFilterMode Then TB1.AutoFilterMode = False ' Autofilter ausschalten
    LR = .Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
    .Rows("1:14").Delete Shift:=xlUp
    .Columns("A:A").Delete Shift:=xlToLeft
    .Columns("C:C").Delete Shift:=xlToLeft
    .Rows("1:1").AutoFilter
    .Range("$A$1:$G$" & LR).AutoFilter Field:=3, Criteria1:=Array( _
    "1", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "2", "20", "21", "22", "23", _
    "24", "25", "26", "27", "28", "29", "3", "30", "31", "32", "33", "34", "35", "36", "37", "38", _
    "39", "4", "40", "41", "42", "5", "6", "7", "8", "9"), Operator:=xlFilterValues
    .Cells.Copy
    Sheets.Add After:=ActiveSheet
    End With
    Set TB2 = ActiveSheet 'das Neue
    With TB2
    .Paste
    Application.CutCopyMode = False
    .Columns("B:C").Insert Shift:=xlToRight
    .Columns("A:A").TextToColumns Destination:=TB2.Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    .Columns("C:C").Delete Shift:=xlToLeft
    .Range("B1").FormulaR1C1 = "Uhrzeit"
    .Rows("1:1").AutoFilter
    .Columns("B:B").NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    .Range("A1").NumberFormat = "m/d/yyyy"
    .Columns("A:A").EntireColumn.AutoFit
    .Columns("C:C").ColumnWidth = 18.57
    .Columns("D:F").EntireColumn.AutoFit
    With .AutoFilter.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=TB2.Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    .Columns("E:G").Insert Shift:=xlToRight
    .Range("E1") = "Desktop"
    .Range("F1") = "Phone"
    .Range("G1") = "Tablet"
    .Range("F2:F" & LR).FormulaR1C1 = "=RC[-2]/100*RC[2]"
    .Range("G2:G" & LR).FormulaR1C1 = "=RC[-3]/100*RC[2]"
    .Range("E2:E" & LR).FormulaR1C1 = "=RC[-1]-RC[1]-RC[2]"
    .Range("E2:G" & LR).Value = .Range("e2:G" & LR).Value 'Formel in Wert
    .Columns("H:L").Delete Shift:=xlToLeft
    End With
    With TB2
    .Name = Format(Date, "DD.MM.YY")
    .Columns("A:A").NumberFormat = "m/d/yyyy"
    End With
    Application.DisplayAlerts = False 'ohne Nachfragen löschen
    Sheets("1 Telebalance FTP").Delete
    Application.DisplayAlerts = True
    Range("I12").Select
    ActiveWorkbook.Save
    Columns("E:G").Select
    End Sub
    
    
    Sub ZellealsWertFERTIGFERTIG()
    On Error Resume Next
    ActiveCell.PasteSpecial xlPasteValues
    End Sub
    
    Leider stimmt bei mri die Zahl der Werte am Ende nciht und ich habe zu wenig Zeilen, das heißt es werden nicht alle berücksichtigt.
    Ich denke es liegt daran dass in Spalte 3 nach allen Werten außer 0 gefiltert werden soll bevor die komplette Tabelle auf das neue Tabellenblatt kopiert wird.
    Scheinbar werden nicht alle Werte korrekt gefiltert so dass es am Ende zu wenige sind.
    Ich hab es selbst schon versucht zu ändern, weß aber nicht genau wie, daher wär ich für eure Hilfe sehr dankbar! :)
    Liebe Grüße,
    Gül
    Anzeige
    AW: Auto Fill Range anpassen
    09.01.2023 17:21:47
    Yal
    Hallo Gül,
    wenn ich das richtig sehe, versuchst Du damit, Daten, die aus eine Datei kommen, zurecht zu stützen.
    Vielleicht wäre eine Einsatz mit Power Query einfacher:
    _ Menü "Daten", "neue Abfrage", "Aus Datei", "aus CSV"
    _ Dateipfad eingeben
    _ auf "Bearbeiten" gehen
    _ Menü "Start", "Zeilen entfernen", "erste Zeilen entfernen", 14 eingeben
    _ Menü "transformieren", "Erste Zeile als Überschrift verwenden"
    _ erste und 4te Spalten markieren, Rechtsklick "Entfernen"
    _ entprechende Spaltenüberschrift ändern "Desktop", "Tablet", usw. (idealerweise recht früh machen, da Spaltenüberschrift für weitere Verarbeitung verwendet werden)
    _ in der (neuen) ersten Spalte auf dem Auswahl, "Typ ändern", "Datum"
    _ Spalte B sortieren (siehe wie die "Schritten" rechts sich ansammeln. Du kannst jede jederzeit löschen, verschieben, ändern)
    _ usw. (mit einer bischen Neugierigkeit kommt man normalerweise gut zurecht)
    Formeln werden mit "benutzerdefinierte Spalte hinzufügen" und Formel eingeben
    _ am Ende: Menü "Datei", "Schliessen & laden"
    _ anschliessen auf die Ergebnis-Tabelle klicken
    _ Menü "Tabellen-Tools", "in Bereich konvertieren"
    _ Arbeitsblatt umbenennen (2023-01-07 ist übrigens besser als 07.01.23 :-)
    _ rechts in "Arbeitsmappenabfragen" ist jetzt die Abfrage in "nur Verbindung"-Modus. Rechtklick auf diese Abfrage auf "laden in ...", "Tabelle" auswählen
    _ es wird dabei ein neues Blatt erzeugt, basierend auf eine erneutes Lesen der Quelldatei, spricht, Du kannst jede Monat der aktuelle Stand der Daten sammeln, solang die Quelldatei immer dieselbe Name hat.
    Power Query besser als VBA? Je nach Aufgaben. Aber in diesem Fall, bei dem es nur darum geht, Daten zu behandeln, schon.
    Weitere Info u.a. unter https://excelhero.de/power-query/power-query-ganz-einfach-erklaert
    VG
    Yal
    Anzeige
    AW: Auto Fill Range anpassen
    11.01.2023 16:41:33
    Piet
    Hallo Gül
    ich bin mir nicht ganz sicher woran es liegt, der Code ist sehr lang. Mich stört die Sortier Routine!
    Da fehlt mir die übliche zweite With Klammer und der Befehl: - SetRange für den Sortierbereich!!
    Schau bitte mal was passiert wenn du den Bereih korrekt als Range angibst.
    mfg Piet
  • With ActiveWorkbook.Worksheets("Tabelle1")
    'LastZell in Spalte A ermitteln
    lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add2 Key:=Range("B1"), SortOn:= _
    xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort 'Sort Bereich angeben!!
    .SetRange Range("A1:xxx" & lz1)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    End With

  • Anzeige
    ob eine Frage noch offen ist,
    11.01.2023 17:48:13
    Yal
    @Piet
    ... liegt in der Auffassung des Fragenden.
    Eine Markierung als "Frage noch offen" ist eine Hilferuf an alle potentiellen Anwortenden, nicht an dem Verfasser. Dafür hat er die Möglichkeit, über die Antwort per Mail informiert zu sein (der Brief-Symbol neben dem ersten Posting).
    Wenn diese innerhalb von 2 Tagen sich nicht meldet, obwohl er die Mail-Benachrichtigung angeschaltet hat, gibt es keine notwendig, allen mit einem roten Ausrufezeichen zu alarmieren.
    Nur meine Meinung.
    VG
    Yal

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige