Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Vergleichen und markieren





Frage

Hallo zusammen Ich sollte die Personalnummer, die in der Tabelle ´Namenliste´ in Spalte A1 bis A1000 steht, mit den Tabellen 1 bis 10 Spalte A1 bis A100 vergleichen und bei Übereinstimmung sollte die Zeile mit der Personalnummer aus der Tabelle ´Namenliste´ grün gefärbt werden. Ich hoffe, es ist klar beschrieben. Danke für die Hilfe. Gruss Balu

Antwort 1 von coros

Hi Balu,

so heißt übrigens auch unser Kater. Kopiere nachfolgendes Makro in ein StandardModul und weise es einer Befehlsschaltfläche zu.

Option Explicit

Sub Vergleichen_und_Hintergundfarbe_ändern()
Dim Letzte_Zeile_Tab_X As Long, Letzte_Zeile_Tab1, _
Wiederholungen As Long, Suchbegriff As Range, _
Wiederholungen_Blätter As Integer
Application.ScreenUpdating = False
Letzte_Zeile_Tab1 = Sheets("Namensliste").Range("A65536").End(xlUp).Row
For Wiederholungen_Blätter = 2 To 11
Letzte_Zeile_Tab_X = Sheets(Wiederholungen_Blätter).Range("A65536").End(xlUp).Row
For Wiederholungen = 2 To Letzte_Zeile_Tab1
With Sheets(Wiederholungen_Blätter).Range("A1:A" & Letzte_Zeile_Tab_X)
Set Suchbegriff = .Find(What:=Sheets("Namensliste").Cells(Wiederholungen, 1), LookIn:=xlValues)
If Not Suchbegriff Is Nothing Then
Addresse = Suchbegriff.Address
Do
Suchbegriff.Interior.ColorIndex = 4
Set Suchbegriff = .FindNext(Suchbegriff)
Loop While Not Suchbegriff Is Nothing And Suchbegriff.Address <> Addresse
End If
End With
Next
Next
End Sub


Bei dem Code werden die Daten aus Spalte A, angefangen von A1 bis zur letzten beschriebenen Zelle in Spalte A, mit den Daten aus den 10 nächsten Tabellenblättern in Spalte A verglichen. Bei Übereinstimmung wird die Zellenhintergrundfarbe der Übereinstimmung in Grün geändert.

Wenn Du eine andere Farbe als das voreingestellt grün haben möchtest, dann musst Du in dem Code in der Zeile

Suchbegriff.Interior.ColorIndex = 4

die Zahl gegen eine andere Indexzahl tauschen. Ein AddIn, welches Dir die Farbindexzahlen auflistet findest Du zum Downlaod meiner HP in der Rubrik Beispieldateien und dort dann Beispiel 43. Auf der gleichen Hompage findest Du auch eine bebilderte Anleitung dazu, wie Du den Code in Deine Datei integrierst. Gehe dazu in die Rubrik Anleitungen und dort dann Anleitung Nr. 3.

Ich hoffe, Du kommst klar. Wenn nicht, oder bei Fragen melde Dich.

MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.

Antwort 2 von flyingbalu

Hallo Coros

Wenn es einen Award für den zuverlässigsten Forumschreiber geben würde, dann wärst du sicher in der engsten Auswahl und auch für die Geschwindigkeit müsste man nicht lange studieren.

Ich habe gerade erfahren, dass ich die Adressdatei in einer separaten Excel-Datei haben muss. Deren Name ist ´Namenliste´ sowie auch das Tabellenblatt darin hat den gleichen Namen. Die Excel-Dateien auf die zugegriffen werden soll nenne ich mal Datei 1 bis 6. Der Aufbau dieser Tabellen ist wie zu Beginn Tabelle 1 bis 10.

Ist sowas überhaubt möglich?

Danke

Balu (auch wenn ich nur zweibeinig bin ;-) )

Antwort 3 von coros

Hi Balu,

kopiere nachfolgendes Makro wieder in ein StandardModul.

Option Explicit

Sub Vergleichen_und_Hintergundfarbe_ändern()
Dim Letzte_Zeile_Tab_X As Long, Letzte_Zeile_Tab1, _
Wiederholungen As Long, Suchbegriff As Range, _
Wiederholungen_Blätter As Integer, Dateianzahl As Long, Zeile As Long, Formel As String, _
Ausgabezelle As String
Application.ScreenUpdating = False
Sheets.Add
Blattname = ActiveSheet.Name
Verzeichnis = ActiveWorkbook.Path
With Application.FileSearch
    .NewSearch
    .LookIn = Verzeichnis
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    .Execute
For Dateianzahl = 1 To .FoundFiles.Count
Worksheets(Blattname).Cells(Dateianzahl, 1) = _
Mid(.FoundFiles.Item(Dateianzahl), Len(Verzeichnis) + 2)
Next Dateianzahl
End With
For Dateien_öffnen = 1 To Sheets(Blattname).Range("A65536").End(xlUp).Row
Dateiname = Workbooks("Namenliste.xls").Sheets(Blattname).Cells(Dateien_öffnen, 1)
If Dateiname <> ThisWorkbook.Name Then
Workbooks.Open Filename:=Verzeichnis & "\" & Dateiname
Letzte_Zeile_Tab1 = Workbooks("Namenliste.xls").Sheets("Namensliste").Range("A65536").End(xlUp).Row
For Wiederholungen_Blätter = 1 To 10
Letzte_Zeile_Tab_X = Workbooks(Dateiname).Sheets(Wiederholungen_Blätter).Range("A65536").End(xlUp).Row
For Wiederholungen = 2 To Letzte_Zeile_Tab1
With Workbooks(Dateiname).Sheets(Wiederholungen_Blätter).Range("A1:A" & Letzte_Zeile_Tab_X)
Set Suchbegriff = .Find(What:=Workbooks("Namenliste.xls").Sheets("Namensliste").Cells(Wiederholungen, 1), LookIn:=xlValues)
If Not Suchbegriff Is Nothing Then
Addresse = Suchbegriff.Address
Do
Suchbegriff.Interior.ColorIndex = 4
Set Suchbegriff = .FindNext(Suchbegriff)
Loop While Not Suchbegriff Is Nothing And Suchbegriff.Address <> Addresse
End If
End With
Next
Next
Windows(Dateiname).Activate
ActiveWorkbook.Save
ActiveWindow.Close
End If
Next
Application.DisplayAlerts = False
Sheets(Blattname).Delete
Application.DisplayAlerts = True
End Sub


Bedingung bei dem Makro ist, dass die Dateien sich alle in dem gleichen Verzeichnis, einschließlich der Datei Namensliste.xls, sich befinden. Das makor macht genau das gleiche wie das alte, außer dass es das Verzeichnis ausließt in dem sich die Datei Namensliste.xls befindet. Die gefundenen Dateien werden alle in einem neu erstellten Tabellenblatt aufegführt. Danach wird jede einzellne Datei geöffnet, die Daten werden verglichen und die Datei wird mit Speichern wieder geschlossen. Zum Schluss wird das Blatt mit den Dateinamen wieder gelöscht.

Teste das mal und gib Bescheid, wenn irgend etwas nicht funktioniert.

MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.

Antwort 4 von flyingbalu

Danke Coros,
ich werde vermutlich erst morgen dazukommen um es auszuprobieren. Werde mich melden.

Gruss
Balu

Antwort 5 von flyingbalu

Hallo Corso

Ich da ich im programmiern wirklich noch ein Anfänger bin, bin ich leider trotz deiner schönen Arbeit nicht weiter gekommen. Was ich nicht weiss, ist welche Teile des Programms ich anpaaen muss. Könntest du mir dabei noch helfen? wäre echt nett!

Inzwischen habe ich folgende Struktur:

Im Folder befinden sich diese Excel-Dateien:
-"Einteilung alt" ( Im Tabellenblatt "Einteilung alt" befinden sich in der Spalt A1 die zu markierenden Personalnummern.)
- "Personal 1" (mit Tabellenblättern "Abteilung 1a" bis "Abteilung 13a" wobei die Personalnummer in der Spalte F steht.)
- "Personal 2" (mit Tabellenblättern "Abteilung 1b" bis "Abteilung 7b" wobei die Personalnummer in der Spalte F steht.)
- "Personal 3" (mit Tabellenblatt "Abteilung 1c" wobei die Personalnummer in der Spalte F steht.)
- "Personal 4" (mit Tabellenblatt"Abteilung 1d" wobei die Personalnummer in der Spalte F steht.)
- "Personal 5" (mit Tabellenblättern "Abteilung 1e" bis "Abteilung 4e" wobei die Personalnummer in der Spalte F steht.)

Ich hoffe es ist nicht zu viel verlangt.

Danke schon im voraus.
Balu

Antwort 6 von coros

Hi balu,

Du solltest erst mal genau wissen, was Du nun eigentlich möchtest. Zuerst Sprichst Du von einer Datei mit 10 Tabellenblättern, dann von 6 Dateien mit wieder 10 Tabellenblättern. Jetzt sind es auf einmal Dateien mit verschieden vielen Tabellenblättern usw.

Also hier der Code, der das machen sollte. Wobei ich jetzt nicht genau weiß, ob es bei Dir nun noch die Datei "Namensliste.xls" gibt oder ob das nun die Datei "Einteilung alt" geworden ist. Wenn es noch die Datei namensliste.xls gibt, dann kannst DU das Makro 1:1 übernehmen. Wenn aber nun das Ausgangsblatt dieses "Einteilung alt" ist, dann musst Du in dem Code überall wo "Namensliste.xls" steht "Einteilung alt.xls" eintragen.

Option Explicit

Sub Vergleichen_und_Hintergundfarbe_ändern()
Dim Letzte_Zeile_Tab_X As Long, Letzte_Zeile_Tab1, _
Wiederholungen As Long, Suchbegriff As Range, _
Wiederholungen_Blätter As Integer, Dateianzahl As Long, Zeile As Long, Formel As String, _
Ausgabezelle As String
Application.ScreenUpdating = False
Sheets.Add
Blattname = ActiveSheet.Name
Verzeichnis = ActiveWorkbook.Path
With Application.FileSearch
    .NewSearch
    .LookIn = Verzeichnis
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    .Execute
For Dateianzahl = 1 To .FoundFiles.Count
Worksheets(Blattname).Cells(Dateianzahl, 1) = _
Mid(.FoundFiles.Item(Dateianzahl), Len(Verzeichnis) + 2)
Next Dateianzahl
End With
For Dateien_öffnen = 1 To Sheets(Blattname).Range("A65536").End(xlUp).Row
Dateiname = Workbooks("Namenliste.xls").Sheets(Blattname).Cells(Dateien_öffnen, 1)
If Dateiname <> ThisWorkbook.Name Then
Workbooks.Open Filename:=Verzeichnis & "\" & Dateiname
Letzte_Zeile_Tab1 = Workbooks("Namenliste.xls").Sheets("Namensliste").Range("A65536").End(xlUp).Row
For Wiederholungen_Blätter = 1 To ActiveWorkbook.Worksheets.Count
Letzte_Zeile_Tab_X = Workbooks(Dateiname).Sheets(Wiederholungen_Blätter).Cells.SpecialCells(xlLastCell).Row
For Wiederholungen = 2 To Letzte_Zeile_Tab1
With Workbooks(Dateiname).Sheets(Wiederholungen_Blätter).Range("A1:F" & Letzte_Zeile_Tab_X)
Set Suchbegriff = .Find(What:=Workbooks("Namenliste.xls").Sheets("Namensliste").Cells(Wiederholungen, 1), LookIn:=xlValues)
If Not Suchbegriff Is Nothing Then
Addresse = Suchbegriff.Address
Do
Suchbegriff.Interior.ColorIndex = 4
Set Suchbegriff = .FindNext(Suchbegriff)
Loop While Not Suchbegriff Is Nothing And Suchbegriff.Address <> Addresse
End If
End With
Next
Next
Windows(Dateiname).Activate
ActiveWorkbook.Save
ActiveWindow.Close
End If
Next
Application.DisplayAlerts = False
Sheets(Blattname).Delete
Application.DisplayAlerts = True
End Sub


So, dass sollte nun funktionieren. Wenn sich wieder was bei Dir ändert, dann gehe erst mal gaaaaanz tief in Dich und überlege, was Du nun eigentlich möchtest. Und wenn Du Dir dann ganz sicher bist, dann schreib hier hin, was geschehen soll. Denn es ist immer sehr schlecht, wenn man sich so sprunghaft was anderes überlegt, weil dann oftmals von dem anfänglichen Makro nicht viel übrig bleibt und man sich immer von neuem Gedanken machen muss. Ganz zu schweigen von der vertanen Arbeit.

Also, teste das mal und melde Dich, wenn Du fragen oder Probleme haben solltest.

MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: