Makro das zeilen löscht und farblich markiert

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Beliebteste Forumthreads (12 Monate)

Makro das zeilen löscht und farblich markiert

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread