Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1456to1460
1456to1460
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Makro das zeilen löscht und farblich markiert

Forumthread: Makro das zeilen löscht und farblich markiert

Makro das zeilen löscht und farblich markiert
05.11.2015 10:39:12
Christian
Hallo an alle,
ich würde euch beten, mir mit einem kleinen Makro auszuhelfen wenn ihr so lieb seid.
Ich habe als Auagangslage eine Arbeitsmappe mit 4 Tabellen namens working list, movies, tv shows und daily soaps.
Das Makro soll die Spalte A der Tabelle Working List mit den Spalten A der anderen Tabellen vergleichen.
1. Kommt einer (oder mehrere) der Texte in Working List!Spalte A in keiner der 3 anderen Spalten A vor soll in der betroffenen Zeile die Schriftfarbe in rot geändert werden
2. Steht in den 3 anderen Tabellen in Spalte A ein Text, der nicht in Working List!Spalte A steht sollen die betroffenen Zeilen aus den anderen Tabellen gelöscht werden.
Ist sowas machbar?
Außerdem mal noch eine andere Frage, ich plane in ferner Zukunft das Ganze als Google Spreadsheet zu machen, weil man dann mit mehreren Leuten gleichzeitig dran arbeiten kann. Ist das Makro dann eigentlich immer noch ausführbar oder wie verhält sich das?
Danke für Eure Hilfe
Christian

Anzeige

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro das zeilen löscht und farblich markiert
05.11.2015 11:47:49
Tino
Hallo,
kannst mal diesen Code bei dir testen!
Option Explicit

Sub Start()
Dim rngList As Range, rngTemp As Range, rngVergleich As Range
Dim oWS, ArWS(), tmpString$

On Error GoTo ErrorHandler:
Call Events_(False)

ArWS = Array(Sheets("movies"), Sheets("tv shows"), Sheets("daily soaps"))

With Worksheets("working list")
    Set rngList = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
    rngList.Font.ColorIndex = xlAutomatic
    Set rngTemp = rngList.EntireRow.Columns(.Columns.Count)
End With

For Each oWS In ArWS
    With oWS
        Set rngVergleich = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
        If rngVergleich.Rows(1).Row > 1 Then 'Daten? 
            tmpString = tmpString & "COUNTIF('" & oWS.Name & "'!" & rngVergleich.Address(1, 1, xlR1C1) & ",RC1),"
        End If
    End With
Next oWS
If tmpString <> "" Then
    tmpString = "SUM(" & Left$(tmpString, Len(tmpString) - 1) & ")=0"
    rngTemp.FormulaR1C1 = "=IF(" & tmpString & ",1,"""")"
    Set rngTemp = FindSpecialCells(rngTemp, 1)
    If Not rngTemp Is Nothing Then
        For Each rngTemp In rngTemp.Areas
            rngTemp.EntireRow.Columns(1).Font.Color = RGB(255, 0, 0)
        Next rngTemp
    End If
    rngList.Parent.Columns(rngList.Parent.Columns.Count).Delete
End If

For Each oWS In ArWS
    With oWS
        Set rngVergleich = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
        If rngVergleich.Rows(1).Row > 1 Then 'Daten? 
            Set rngTemp = rngVergleich.EntireRow.Columns(.Columns.Count)
            tmpString = "COUNTIF(" & rngList.Address(1, 1, xlR1C1, True) & ",RC1)=0"
            rngTemp.FormulaR1C1 = "=IF(" & tmpString & ",1,"""")"
            Set rngTemp = FindSpecialCells(rngTemp, 1)
            If Not rngTemp Is Nothing Then
                rngTemp.EntireRow.Delete
            End If
            .Columns(.Columns.Count).Delete
        End If
    End With
Next oWS

ErrorHandler:
Call Events_(True)
If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub

Function FindSpecialCells(rngBereich As Range, iFunktion%) As Range
On Error Resume Next
    Set FindSpecialCells = rngBereich.SpecialCells(xlCellTypeFormulas, iFunktion)
On Error GoTo 0
End Function

Sub Events_(booSchalter As Boolean)
With Application
    .ScreenUpdating = booSchalter
    .DisplayAlerts = booSchalter
    .EnableEvents = booSchalter
    .Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Gruß Tino

Anzeige
AW: Makro das zeilen löscht und farblich markiert
05.11.2015 17:53:20
Christian
Hallo Tino,
ich muss mich glaub erstmal entschuldigen, ich hab absolut nicht damit gerechnet dass das so aufwendig wird. Soweit scheint es aber zu funktionieren.
Es ist allerdings noch meine Frage offen ob man so ein Makro auch in ein Google Spreadsheet irgendwie übernehmen kann.
Außerdem mir ist leider noch eines eingefallen, woran ich vorhin nicht gedacht habe, wäre wirklich toll von dir wenn du das trotzdem noch ins Makro einbauen könntest.
Und zwar wenn in working list Spalte E ein X steht soll diese Zeile auf jedenfall schwarz bleiben, auch wenn sie ansonsten das Kriterium für die rote Färbung erfüllt. Bist du bitte so lieb und baust auch das noch ins Makro ein?
Vielen Dank für die Mühe
Christian

Anzeige
AW: Makro das zeilen löscht und farblich markiert
05.11.2015 18:24:18
Tino
Hallo,
zu 1.
kann ich nicht sagen, habe mich damit noch nicht beschäftigt.
zu 2.
versuch mal und mach aus der Zeile (nach der Zeile mit tmpString = "SUM(")
rngTemp.FormulaR1C1 = "=IF(" & tmpString & ",1,"""")"
diese
rngTemp.FormulaR1C1 = "=IF(LOWER(RC5)=""x"","""",IF(" & tmpString & ",1,""""))"
Gruß Tino

Anzeige
AW: Makro das zeilen löscht und farblich markiert
05.11.2015 18:46:37
Christian
Hallo Tino,
danke vielmals, das scheint soweit zu funktionieren.
Brauche ich dann nur noch hilfe mit dem Google.
Danke vielmals
Christian

AW: Makro das zeilen löscht und farblich markiert
06.11.2015 13:46:36
Christian
Hallo Tino,
sorry dass ich mich nochmal melde, aber selbst wenn ich die Tabellen zurückkopiere aus dem Google Spreadsheet in Excel um das Makro auszuführen habe ich gemerkt, dass beim Kopieren von Excel in Google Spreadsheet die rote Farbe verloren geht.
Also brauche ich eine andere Lösung z.B. ein "N" in Spalte F in den Zeilen die vorher die rote Farbe bekommen haben, also selbe Kriterien wie für die rote Farbe.
Bist du bitte nochmal so nett?
Christian

Anzeige
AW: Makro das zeilen löscht und farblich markiert
06.11.2015 15:15:52
Tino
Hallo,
teste mal ob es so geht!
Option Explicit
Sub Start()
Dim rngList As Range, rngTemp As Range, rngVergleich As Range
Dim oWS, ArWS(), tmpString$
On Error GoTo ErrorHandler:
Call Events_(False)
ArWS = Array(Sheets("movies"), Sheets("tv shows"), Sheets("daily soaps"))
With Worksheets("working list")
Set rngList = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
rngList.Font.ColorIndex = xlAutomatic
rngList.EntireRow.Columns(6).Value = Empty
Set rngTemp = rngList.EntireRow.Columns(.Columns.Count)
End With
For Each oWS In ArWS
With oWS
Set rngVergleich = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
If rngVergleich.Rows(1).Row > 1 Then 'Daten?
tmpString = tmpString & "COUNTIF('" & oWS.Name & "'!" & _
rngVergleich.Address(1, 1, xlR1C1) & ",RC1),"
End If
End With
Next oWS
If tmpString  "" Then
tmpString = "SUM(" & Left$(tmpString, Len(tmpString) - 1) & ")=0"
rngTemp.FormulaR1C1 = "=IF(LOWER(RC5)=""x"","""",IF(" & tmpString & ",1,""""))"
Set rngTemp = FindSpecialCells(rngTemp, 1)
If Not rngTemp Is Nothing Then
For Each rngTemp In rngTemp.Areas
rngTemp.EntireRow.Columns(1).Font.Color = RGB(255, 0, 0)
rngTemp.EntireRow.Columns(6).Value = "N"
Next rngTemp
End If
rngList.Parent.Columns(rngList.Parent.Columns.Count).Delete
End If
For Each oWS In ArWS
With oWS
Set rngVergleich = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
If rngVergleich.Rows(1).Row > 1 Then 'Daten?
Set rngTemp = rngVergleich.EntireRow.Columns(.Columns.Count)
tmpString = "COUNTIF(" & rngList.Address(1, 1, xlR1C1, True) & ",RC1)=0"
rngTemp.FormulaR1C1 = "=IF(" & tmpString & ",1,"""")"
Set rngTemp = FindSpecialCells(rngTemp, 1)
If Not rngTemp Is Nothing Then
rngTemp.EntireRow.Delete
End If
.Columns(.Columns.Count).Delete
End If
End With
Next oWS
ErrorHandler:
Call Events_(True)
If Err.Number  0 Then
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Function FindSpecialCells(rngBereich As Range, iFunktion%) As Range
On Error Resume Next
Set FindSpecialCells = rngBereich.SpecialCells(xlCellTypeFormulas, iFunktion)
On Error GoTo 0
End Function
Sub Events_(booSchalter As Boolean)
With Application
.ScreenUpdating = booSchalter
.DisplayAlerts = booSchalter
.EnableEvents = booSchalter
.Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Gruß Tino

Anzeige
AW: Makro das zeilen löscht und farblich markiert
06.11.2015 15:29:01
Christian
Hallo Tino,
das Makro färbt zwar immer noch rot, das mit dem N war eigentlich ersatzweise gemeint, nicht zusätzlich aber soweit funktioniert es.
Danke
Christian

AW: Makro das zeilen löscht und farblich markiert
06.11.2015 16:30:07
Tino
Hallo,
mach die zwei Zeilen raus 
rngList.Font.ColorIndex = xlAutomatic

und 
rngTemp.EntireRow.Columns(1).Font.Color = RGB(255, 0, 0)
Dann sollte keine Färbung mehr stattfinden!
Gruß Tino

Anzeige
AW: Makro das zeilen löscht und farblich markiert
06.11.2015 16:42:00
Christian
Hallo Tino, die zweite Zeile leuchtete mir ein, mit der ersten war mir nicht ganz klar was damit bezweckt wird, daher hab ich sicherheitshalber um eine Änderung von deiner Seite gebeten.
Aber vielen Dank
Klappt
Christian

AW: Makro das zeilen löscht und farblich markiert
06.11.2015 18:01:57
Tino
Hallo,
die erste setzt die Schriftfarbe auf Standard
die zweite färbt rot bei der die Bedingung erfüllt ist.
Gruß Tino

Anzeige
AW: Makro das zeilen löscht und farblich markiert
06.11.2015 18:21:55
Christian
danke, Christan

Beliebteste Forumthreads (12 Monate)

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