Viele Dateien zusammenfassen

[Phi.VBA]

@Igelbauer

vielleicht hilft es, vielleicht trägt es zur Verwirrung bei:

Der Code prüft alle Dateien und trägt Änderungen in ein Log-File.

In ein neues, mit den Sheets("Log") und den genannten Überschriften in das Verzeichnis kopieren (besser mit wenigen Dateien in einer Testumgebung)

Code:

Private Declare Function OemToCharA Lib "user32.dll" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
       
Public Function F_ASC_ANS(ByVal Text As String) As String
  OemToCharA Text, Text
  F_ASC_ANS = Text
End Function


'Sheets("Log"): Datum, Zelle, alt, neu, User (headings in Zeile 1)
Sub Loggen()
Dim WBa As Workbook, WBn As Workbook
Dim LC As Range
Dim rLog As Long
Dim sPath As String

sPath = ThisWorkbook.Path & "\"

 Fi = Split(F_ASC_ANS(CreateObject("wscript.shell").exec("cmd /c Dir """ & sPath & "*.xls?"" /b/od").stdout.readall), vbCrLf)
'Fi = Filter(Fi, ThisWorkbook.Name, False) 'aus sonst leerem WB nicht notwendg
rLog = Sheets("Log").Cells(Rows.Count, 1).End(xlUp).Row + 1
For f = 0 To UBound(Fi) - 1
   Debug.Print Fi(f), Fi(f + 1)
   Set WBa = Workbooks.Open(sPath & Fi(f))
   Set WBn = Workbooks.Open(sPath & Fi(f + 1))
   With WBn.Sheets(1).UsedRange
       If WBa.Sheets(1).UsedRange.Address = .Address Then
           Set LC = .SpecialCells(11)
           For i = 1 To LC.Row
               For j = 1 To LC.Column
                   If .Cells(i, j) <> WBa.Sheets(1).Cells(i, j) Then
                       ThisWorkbook.Sheets("Log").Cells(rLog, 1) = .Parent.Parent.BuiltinDocumentProperties("Last save time").Value
                       ThisWorkbook.Sheets("Log").Cells(rLog, 2) = .Cells(i, j).Address
                       ThisWorkbook.Sheets("Log").Cells(rLog, 3) = WBa.Sheets(1).Cells(i, j)
                       ThisWorkbook.Sheets("Log").Cells(rLog, 4) = .Cells(i, j)
                       ThisWorkbook.Sheets("Log").Cells(rLog, 5) = .Parent.Parent.BuiltinDocumentProperties("Last Author").Value
                       rLog = rLog + 1
                   End If
               Next j
           Next i
       Else
           MsgBox "unterschiedliche UsedRange"
       End If
   End With

WBa.Close 0
WBn.Close 0

Next f
End Sub

Die Annahme ist, dass die UsedRange gleich sind, sonst muss weiterer Code in den "else"-Teil eingefügt werden.

Schaun wir mal ...

[Igelbauer]

@Phi
Nochmal vielen vielen Dank für die Mühe.
Hab mal grob drübergeschaut. Die teilweise fehlende Variablendeklaration dürfte das kleinste Problem sein.
Das nehm ich mir heute abend mal mit nach Hause.
Hier ist konzentriertes Arbeiten momentan kaum möglich.

Gruss Igel

[Igelbauer]

Eine letzte Bestandsaufnahme, dann mach ich dieses Thema erst mal zu.
Hab gestern Abend den Code fast ans laufen gekriegt, da hat es an der Tür geklingelt.
Letzter Haken war, dass er mir den UsedRange ziemlich sinnlos festgelegt hat.
Weiss nicht ob das evtl. mit Fixierung oder verbundenen Zellen in der Überschrift zusammenhängt.
Kein Problem, krieg ich noch raus, oder ich leg den Bereich selber fest.
Die Dateien sind ja im Prinzip identisch, bis auf die Werte in einigen Zellen.
Die UFo nervt auch immer noch, aber auch das löse ich irgendwie.
Ich habe in diesem Thema sehr viel gelernt.
Dafür danke ich nochmal allen die dazu beigetragen haben. Vor allem Phi.
Und jetzt habe ich eine schöne Aufgabe fürs Wochenende.
Was soll man auch sonst machen bei dem Sch...wetter.

Igel

[Phi.VBA]

@Igelbauer

gut.

Das Auflösen der Bedingung "selber UsedRange" ist mit wenigen Befehlen (1x Union, 1 x Intersect) und dem Wechseln zwischen Range und einem Text der Adresse möglich.

Über eine Prüfung desZeitstempels kann der Code auch mehrfach laufen.

Also das Projekt ist machbar.

[Phi.VBA]

@Alle

Kommentar von Igelbauer: "Sch... UFo"

So kann man Makros, die mit Workbook.Open gestartet werden, abschalten:

Code:

Sub T1()
Dim WB As Workbook
iPath = ThisWorkbook.Path & "\"
Application.AutomationSecurity = msoAutomationSecurityForceDisable

   Set WB = Workbooks.Open(iPath & "mit UserForm.xlsm")

Application.AutomationSecurity = msoAutomationSecurityLow
End Sub

Auch "MergedCells" können mit einem Befehl "Cells.UnMerge" aufgelöst werden (dann aber nicht speichern)

[Igelbauer]

Da denkt man, man ist glücklich.
Und dann kommt einer und macht dich noch glücklicher.
:19: :19: :19: