Zeilen Doppelter Werte nach addieren löschen

[atilla]

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.

[Frank BST]

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

[Frank BST]

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

[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.

[atilla]

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

[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

[Frank BST]

Jetzt steht nur noch die Frage warum das Haupt-Makro nicht Datei übergreifend arbeitet.
Siehe meinen Beitrag '#30' auf Seite 


Da ich das Makro in der Firma nutzen möchte wäre es mir lieb wenn die Hauptdatei im *.xlsx Format bleiben könnte.

[Frank BST]

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

[Rabe]

Hi Frank,

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?

[atilla]

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.