Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Frank,
Die eine Zeile sollte ja im vorhandenen Code ergänzt werden.
So, wie Du es machen möchtest, muss der Punkt vor Columns weg.
Gruß Atilla
Registriert seit: 26.02.2016
Version(en): 2007
Moin Moin Atilla,
leider gibt's auch ohne 'Punkt' noch ne Fehlermeldung
Code: Sub hintergrundfarbe_weg()
'
' Markierungrückgaengig Makro
'
Range("Tabelle5").Interior.ColorIndex = xlNone
Columns(lngS).Clear
End Sub
Fehler Kompilieren
Bezieht sich auf '(lngS)'
Dies soll ein eigenständiges Makro sein.
Nach dem Lauf des ersten Makros und Anschließender manueller Bearbeitung der Markierten Werte soll das dieses zum Einsatz kommen.
Um die Liste wieder unmarkiert, ohne Zusatzspalten also jungfräulich zu machen.
Gruß
Frank
Registriert seit: 26.02.2016
Version(en): 2007
Woran liegt es, dass die Excel Makro Dateien nach wenigen Makro Aktionen von der Speichergröße her explodieren?
Zu beginn hat meine derzeitige Tabelle ca. 150 KB.
Nach wenigen Makro läufen ist die Datei auf 26 MB angewachsen.
Obwohl auf ca. 5000 Zeilen nur ca. 50 Zeilen dazu kamen.
(auf ca. 90 Spalten mit wenig befüllten Zellen (vielleicht 2%))
:s :s
Registriert seit: 14.04.2014
Version(en): 2003, 2007
08.03.2016, 11:02
(Dieser Beitrag wurde zuletzt bearbeitet: 08.03.2016, 11:02 von atilla.)
Hallo Frank,
wenn ich nicht aufpasse, dann musst Du selber ein wenig mitdenken.
lngS ist ja gar nicht belegt, also kann es auch nicht funktionieren.
So sollte es gehen:
Code: Sub hintergrundfarbe_weg()
'
' Markierungrückgaengig Makro
'
Dim lngS As Long
lngS = Cells(4, Columns.Count).End(xlToLeft).Column
Range("Tabelle1").Interior.ColorIndex = xlNone
Columns(lngS).Delete
End Sub
Es wird jetzt die Spalte gelöscht und nicht mehr nur die Inhalte. Anders blieb immer eine Überschrift der Spalte.
Gruß Atilla
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo noch einmal,
und wegen der Tabelle geht natürlich auch so:
Code: Sub hintergrundfarbe_weg()
' und letzte Spalte der Tabelle weg
' Markierungrückgaengig Makro
'
Range("Tabelle5").Interior.ColorIndex = xlNone
Columns(Range("Tabelle5").Columns.Count).Delete
End Sub
Gruß Atilla
Registriert seit: 26.02.2016
Version(en): 2007
08.03.2016, 14:25
(Dieser Beitrag wurde zuletzt bearbeitet: 08.03.2016, 14:25 von Frank BST.)
Oh Super,
danke Atilla es läuft.
Ich hatte mich schon gar nicht mehr getraut zu fragen denn trotz dutzender Versuche brachte ich die erste Version nicht zum laufen.
(Fehler 400)
Wenn ich die Makro Aufzeichnung nutze kann ich entstehenden Code ja noch mit hängen und würgen deuten und abändern.
Aber in dieser Form des VBA Codes erkenne ich nur Hieroglyphen :s :s
Registriert seit: 26.02.2016
Version(en): 2007
Registriert seit: 26.02.2016
Version(en): 2007
Ich hab die *.xlsx Datei nochmal unter *.xlsm abgespeichert, in der aber ebenfalls kein Makro gespeichert ist.
Wenn ich das Makro der zweiten Makro Datei laufen lasse ist das Ergebnis identisch mit meinem Fehler von Post #30
Registriert seit: 10.04.2014
Version(en): 2016 + 365
Hi Frank,
(08.03.2016, 15:05)Frank BST schrieb: Ich hab die *.xlsx Datei nochmal unter *.xlsm abgespeichert, in der aber ebenfalls kein Makro gespeichert ist.
Nur weil eine Datei xlsm heißt, muß da nicht ein Makro drin sein.
Wenn eine abgespeicherte xlsx als xlsm abgespeichert wird, dann ist auch in der xlsm kein Makro drin. Wo soll es auch her kommen, das wurde ja beim Speichern der xlsx gelöscht?
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Frank,
teste bitte mit folgendem Code:
Code: Option Explicit
Sub Löschen()
Dim i As Long, j As Long
Dim lngS As Long ' die letzte belegte Spalte in Zeile 4
Dim lngZ As Long ' die letzte belegte Zeile in Spalte A
Dim dblS As Double
Dim rngA As Range
On Error GoTo Ende
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Tabelle1")
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, 1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Range(.Cells(5, lngS + 2), .Cells(lngZ, lngS + 2)).FormulaLocal = "=Wenn(A5<>A4;ZÄHLENWENN(A:A;A5);0)"
For i = 5 To lngZ
If .Cells(i, lngS + 2) > 1 Then
If .Cells(i, 1) = .Cells(i + 1, 1) Then
For j = 2 To lngS
dblS = Application.WorksheetFunction.Sum(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j)))
If dblS > 0 Then
If Application.Count(.Range(.Cells(i, j), .Cells(i + .Cells(i, lngS + 2) - 1, j))) > 1 Then
.Cells(i, lngS + 1) = 1
If rngA Is Nothing Then
Set rngA = .Cells(i, j)
Else
Set rngA = Union(rngA, .Cells(i, j))
End If
End If
.Cells(i, j) = dblS
End If
Next j
End If
End If
Next i
.Range(.Cells(5, 1), .Cells(lngZ, lngS)).Interior.ColorIndex = xlNone
If Not rngA Is Nothing Then
rngA.Interior.ColorIndex = 3
End If
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).RemoveDuplicates Columns:=1, Header:=xlYes
.Columns(lngS + 2).Clear
If Not rngA Is Nothing Then
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
lngS = .Cells(4, Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 1), .Cells(lngZ, lngS)).Sort _
Key1:=.Cells(4, lngS), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Set rngA = Nothing
End If
End With
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Ende:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & Err.Description
End Sub
Eigentlich hätte der bisherige gar nicht funktionieren dürfen.
Denn es fehlte vor einigen Cells Angaben der Punkt.
Achte bitte selber auch darauf, vor jeder Range und Cells muss ein Punkt.
Am besten den Code in ein allgemeines Modul einfügen und von dort starten.
Wenn ein Fehler mit "Index ausserhalb...bla.. bla" kommt, dann prüf bitte ob das Blatt "Tabelle1" heißt.
Gruß Atilla
|