Tabelle: Zeilen vergleichen-Unterschiede markieren
16.06.2015 09:13:12
DAEMAN
danke für den Vorschlag mit der bedingten Formatierung, und ja darauf bin ich auch schon gekommen, nur wollte ich eine vollständige VBA-Lösung, da die Excel-Tabelle einfach viel zu groß und variabel ist für eine bedingte Formatierung...
Ich werde hier mal die wesentlichen Teile des VBA Codes aufführen, und hoffe, jemand kommt eine Idee, wie man mein o.g. Ziel erreichen kann!
CODE:
Private Sub IMPORT_PROJECTS_Click()
On Error Resume Next
Dim ws As Worksheet, Lo As ListObject, objWord As Object, _
Doc As Object, cXML As CustomXMLPart, myXMLPart As CustomXMLPart, _
FS As New FileSearch, File As Variant, Datum As Date
'Tabelle im Dokument referenzieren
Set ws = Worksheets(1)
'List-Object Tabelle mit Namen referenzieren
Set Lo = ws.ListObjects("COLLATION")
'Word Objekt erzeugen
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
objWord.DisplayAlerts = False
'ANZEIGE: Aktualisierungen unsichtbar
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Automatische Suche nach allen .docx Dateien im vordefinierten Pfad (inkl. Unterornder - _
Klassenmodul, ähnlich dem alten Filesearch aus Excel 2003)
With FS
.FileName = "*.docx"
.LookIn = "V:\NST_FILER\Dept\PRM\All\06_Documents\DEN\PIS\BACKUP\TEST"
'.LookIn = "\\notion\compprojects\ProjectPlanningExecution\GenProjectInfo\Lists\Project _
Information Sheet\Attachments"
.SearchSubFolders = True
.Execute
'Für jede Datei die gefunden wurde ..
For Each File In .FoundFiles
'Öffne die Datei
Set Doc = objWord.Documents.Open(File)
'Suche das CustomXML im Dokument
For Each cXML In Doc.CustomXMLParts
If cXML.BuiltIn = False Then
Set rootNode = cXML.SelectSingleNode("root")
If Not rootNode Is Nothing Then
Set myXMLPart = cXML
Exit For
End If
End If
Next
'Wenn der CustomXML-Part gefunden wurde ...
If Not myXMLPart Is Nothing Then
'Formularfelder zu Variablen zuordnen
strProject = myXMLPart.SelectSingleNode("/root/Project").Text
strDate1 = myXMLPart.SelectSingleNode("/root/Date1").Text
usw...
Lo.ListRows.Add
Lo.ListRows(Lo.ListRows.Count).Range(1, 1) = strProject
Lo.ListRows(Lo.ListRows.Count).Range(1, 2) = strDate1
usw....
End If
'Dokument schließen
Doc.Close False
Next
'Word schließen
objWord.DisplayAlerts = False
objWord.Quit
Set objWord = Nothing
'SORTIERUNG: PROJEKTNAME
Lo.Sort.SortFields.Add Key:=Range("A5"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With Lo.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'SORTIERUNG: Chronologisch, absteigend
Lo.Sort.SortFields.Add Key:=Range("C5"), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
With Lo.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Jetzt fehlt mir nur noch der Vergleich der Zeilen (jede Spalte einzeln durchlaufen), die denselben Projektnamen besitzen - es soll das neuste Änderungsdatum mit dem zweit neusten verglichen werden
'Bei Unterschieden sollen beide markiert werden, zudem soll in die neuere Zelle ein Kommentar eingefügt werden, der den Inhalt der älteren Zelle enthält...
Hat jemand eine Idee?
Danke + Gruß
DAEMAN