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

Tabellen vergleichen + Änderungsprotokoll

Tabellen vergleichen + Änderungsprotokoll
15.08.2006 17:23:00
Melanie
Hallo zusammen!
Ich möchte gerne 2 riesige Tabellen (Materialstamm) miteinander vergleichen (50000 Zeilen, 64 Spalten) und über Änderungen ein Protokoll erstellen.
Situation:
in Tabelle 2 soll verglichen werden, ob die Artikelnummer in der Quelldatei vorkommt. Wenn ja, sollen die folgenden 63 Spalten auf Änderungen untersucht werden. Bei einer Änderung soll ein neues Tabellenblatt erstellt werden und die Änderung protokolliert werden.
Bsp.
Art.nr. Spaltenüberschrift Wert_alt Wert_neu
4711 Disponent 0 1
4712 Beschaffungsart E F
4712 WBZ 2 20
4713 Losgröße 1000 10
4714 NEU
die Spalten sollen bis zum Ende durchsucht werden, d.h. es können mehrere Änderungen vorkommen.
Und natürlich sollen die restlichen Zeilen auch noch durchsucht werden.
Befindet sich ein Artikel nicht in der Quelldatei soll in der Spalte "Spaltenüberschrit" der Eintrag "NEU" eingetragen werden.
Ist so etwas machbar?
Und wenn ja: wie?
Wäre für Eure Hilfe sehr dankbar :-)))
Gruß
Melanie

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellen vergleichen + Änderungsprotokoll
15.08.2006 17:28:23
Josef
Hallo Melanie!
Machbar ist fast alles;-)
Zeig mal wie die Tabellen aufgebaut sind.
Gruß Sepp

AW: Tabellen vergleichen + Änderungsprotokoll
15.08.2006 21:00:35
Josef
Hallo Melanie!
Ich hab mal angenommen, daß die Daten ab "A2" in den Tabellen stehen.
Die erste Zeile enthält die Überschriften.
Die Tabellennamen und den Pfad zur 2. Datei musst du anpassen
Der Code gehört in ein allgemeines Modul der Mappe mit den aktuellen Werten.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub CompareAndReport()
Dim objWB As Workbook
Dim objSh As Worksheet, objSrc As Worksheet
Dim strFile As String
Dim lngR As Long, lngN As Long, intC As Integer
Dim vVal1 As Variant, vVal2 As Variant, vNew() As Variant, vLink() As Variant
Dim rng As Range


On Error GoTo ErrExit
GetMoreSpeed

Application.StatusBar = "Datenvergleich - Lese Daten - Bitte warten!"

strFile = "F:\Temp\Vergleich\Datei2.xls" ' Die zu vergleichende Datei! - Anpassen!

Set objWB = Workbooks.Open(strFile)

With objWB.Sheets("Tabelle1") ' Tabellenname anpassen (Vergleichende!)
  vVal2 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

objWB.Close False

Set objSrc = ThisWorkbook.Sheets("Tabelle1") ' Tabellenname anpassen (Diese Datei)

With objSrc
  vVal1 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

With ThisWorkbook
  Set objSh = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With

objSh.Name = "Protokoll " & Format(Now, "dd_mm_yy hhmmss")

Redim vNew(1 To UBound(vVal1, 1), 1 To 4)
Redim vLink(1 To UBound(vVal1, 1))

For lngR = 2 To UBound(vVal1, 1)
  Application.StatusBar = "Datenvergleich - Vergleiche Datensatz " & lngR & " von " & UBound(vVal1, 1) & " - Bitte warten!"
  Set rng = objSrc.Range("A:A").Find(what:=vVal2(lngR, 1), lookat:=xlWhole)
  If Not rng Is Nothing Then
    For intC = 2 To UBound(vVal1, 2)
      If vVal1(lngR, intC) <> vVal2(lngR, intC) Then
        lngN = lngN + 1
        vNew(lngN, 1) = vVal1(lngR, 1)
        vNew(lngN, 2) = vVal1(1, intC)
        vNew(lngN, 3) = vVal1(lngR, intC)
        vNew(lngN, 4) = vVal2(lngR, intC)
        vLink(lngN) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
      End If
    Next
  Else
    lngN = lngN + 1
    vNew(lngN, 1) = vVal1(lngR, 1)
    vNew(lngN, 2) = "NEU"
    vLink(lngN) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
  End If
Next

Application.StatusBar = "Datenvergleich - Erstelle Protokoll - Bitte warten!"

With objSh
  If lngN > 0 Then
    .Cells(1, 1) = "Art. Nr."
    .Cells(1, 2) = "Spaltenbezeichnung"
    .Cells(1, 3) = "Neuer Wert"
    .Cells(1, 4) = "Alter Wert"
    .Range("A1:D1").Font.Bold = True
    .Range(.Cells(2, 1), .Cells(lngN + 1, 4)) = vNew
    For lngR = 1 To lngN
      .Hyperlinks.Add Anchor:=.Cells(lngR + 1, 1), Address:="", SubAddress:=vLink(lngR)
    Next
  Else
    .Cells(1, 1) = "Keine Abweichungen vorhanden!"
  End If
  .Columns.AutoFit
End With

ErrExit:

If Err Then
  MsgBox Err.Number & vbLf & Err.Description
End If

Application.StatusBar = False
Set objWB = Nothing
Set objSh = Nothing

GetMoreSpeed 0

End Sub



Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc > 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub


Gruß Sepp

Anzeige
AW: Tabellen vergleichen + Änderungsprotokoll
16.08.2006 22:47:44
Melanie
Hallo Sepp!
Vielen Dank vorab für Deine Hilfe - ich bin erst am Freitag wieder im Büro und werde dann testen :-))))
und natürlich berichten :-))))
Gruß
Melanie
Tip-top!!!
17.08.2006 15:56:37
Melanie
WOOOWWWWW!
Das klappt ja bombastisch!
Jetzt werde ich nur noch versuchen, den Code zu verstehen ;-)))
1000 Dank und Gruß,
Melanie
AW: Tip-top!!! aber...
17.08.2006 19:46:53
Josef
Hallo Melanie!
.. ein kleiner Logikfehler war noch drin!
So stimmts.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub CompareAndReport()
Dim objWB As Workbook
Dim objSh As Worksheet, objSrc As Worksheet, objTar As Worksheet
Dim strFile As String
Dim lngR As Long, lngN As Long, intC As Integer
Dim vVal1 As Variant, vVal2 As Variant, vNew() As Variant, vLink() As Variant
Dim rng As Range


On Error GoTo ErrExit
GetMoreSpeed

Application.StatusBar = "Datenvergleich - Lese Daten - Bitte warten!"

strFile = "F:\Temp\Vergleich\Datei2.xls" ' Die zu vergleichende Datei! - Anpassen!

Set objWB = Workbooks.Open(strFile)

Set objTar = objWB.Sheets("Tabelle1") ' Tabellenname anpassen (Vergleichende!)

With objTar
  vVal2 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

Set objSrc = ThisWorkbook.Sheets("Tabelle1") ' Tabellenname anpassen (Diese Datei)

With objSrc
  vVal1 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

With ThisWorkbook
  Set objSh = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With

objSh.Name = "Protokoll " & Format(Now, "dd_mm_yy hhmmss")

Redim vNew(1 To UBound(vVal1, 1), 1 To 4)
Redim vLink(1 To UBound(vVal1, 1), 1 To 2)

For lngR = 2 To UBound(vVal1, 1)
  Application.StatusBar = "Datenvergleich - Erledigt zu " & Format(lngR / UBound(vVal1, 1), "0 %") & " - Bitte warten!"
  Set rng = objTar.Range("A:A").Find(what:=vVal1(lngR, 1), lookat:=xlWhole)
  If Not rng Is Nothing Then
    For intC = 2 To UBound(vVal1, 2)
      If vVal1(rng.Row, intC) <> vVal2(rng.Row, intC) Then
        lngN = lngN + 1
        vNew(lngN, 1) = vVal1(lngR, 1)
        vNew(lngN, 2) = vVal1(1, intC)
        vNew(lngN, 3) = vVal1(lngR, intC)
        vNew(lngN, 4) = vVal2(rng.Row, intC)
        vLink(lngN, 1) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
        vLink(lngN, 2) = "'" & objSrc.Name & "'!" & Cells(lngR, intC).Address(0, 0)
      End If
    Next
  Else
    lngN = lngN + 1
    vNew(lngN, 1) = vVal1(lngR, 1)
    vNew(lngN, 2) = "NEU"
    vLink(lngN, 1) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
  End If
Next

Application.StatusBar = "Datenvergleich - Erstelle Protokoll - Bitte warten!"

With objSh
  If lngN > 0 Then
    .Cells(1, 1) = "Art. Nr."
    .Cells(1, 2) = "Spaltenbezeichnung"
    .Cells(1, 3) = "Neuer Wert"
    .Cells(1, 4) = "Alter Wert"
    .Range("A1:D1").Font.Bold = True
    .Range(.Cells(2, 1), .Cells(lngN + 1, 4)) = vNew
    For lngR = 1 To lngN
      .Hyperlinks.Add Anchor:=.Cells(lngR + 1, 1), Address:="", SubAddress:=vLink(lngR, 1)
      If vLink(lngR, 2) <> "" Then .Hyperlinks.Add Anchor:=.Cells(lngR + 1, 3), Address:="", SubAddress:=vLink(lngR, 2)
    Next
  Else
    .Cells(1, 1) = "Keine Abweichungen vorhanden!"
  End If
  .Columns.AutoFit
End With

ErrExit:

If Err Then
  MsgBox Err.Number & vbLf & Err.Description
  Err.Clear
End If

Application.StatusBar = False
Set objSrc = Nothing
Set objTar = Nothing
If Not objWB Is Nothing Then objWB.Close False
Set objWB = Nothing
Set objSh = Nothing

GetMoreSpeed 0

End Sub



Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub


Gruß Sepp

Anzeige
Schneller
17.08.2006 23:01:20
Josef
Hallo Melanie!
Und hier das ganze noch etwas schneller und genauer.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
Private vCom As Variant

Sub CompareAndReport()
Dim objWB As Workbook
Dim objSh As Worksheet, objSrc As Worksheet, objTar As Worksheet
Dim strFile As String
Dim lngR As Long, lngN As Long, lngI As Long, intC As Integer
Dim vVal1 As Variant, vVal2 As Variant, vNew() As Variant, vLink() As Variant


On Error GoTo ErrExit
GetMoreSpeed

Application.StatusBar = "Datenvergleich - Lese Daten - Bitte warten!"

strFile = "F:\Temp\Vergleich\Datei2.xls" ' Die zu vergleichende Datei! - Anpassen!

Set objWB = Workbooks.Open(strFile)

Set objTar = objWB.Sheets("Tabelle1") ' Tabellenname anpassen (Vergleichende!)

With objTar
  vVal2 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
  vCom = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

objWB.Close False

Set objSrc = ThisWorkbook.Sheets("Tabelle1") ' Tabellenname anpassen (Diese Datei)

With objSrc
  vVal1 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

With ThisWorkbook
  Set objSh = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With

objSh.Name = "Protokoll " & Format(Now, "dd_mm_yy hhmmss")

Redim vNew(1 To Rows.Count, 1 To 4)
Redim vLink(1 To Rows.Count, 1 To 2)

For lngR = 2 To UBound(vVal1, 1)
  Application.StatusBar = "Datenvergleich - [ " & Format(lngR / UBound(vVal1, 1), "0 %") & " ] - Bitte warten!"
  lngI = FindInArray(vVal1(lngR, 1))
  If lngI > -1 Then
    For intC = 2 To UBound(vVal1, 2)
      If vVal1(lngR, intC) <> vVal2(lngI, intC) Then
        lngN = lngN + 1
        vNew(lngN, 1) = vVal1(lngR, 1)
        vNew(lngN, 2) = vVal1(1, intC)
        vNew(lngN, 3) = vVal1(lngR, intC)
        vNew(lngN, 4) = vVal2(lngI, intC)
        vLink(lngN, 1) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
        vLink(lngN, 2) = "'" & objSrc.Name & "'!" & Cells(lngR, intC).Address(0, 0)
      End If
    Next
  Else
    lngN = lngN + 1
    vNew(lngN, 1) = vVal1(lngR, 1)
    vNew(lngN, 2) = "NEU"
    vLink(lngN, 1) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
  End If
Next

Application.StatusBar = "Datenvergleich - Erstelle Protokoll - Bitte warten!"

With objSh
  If lngN > 0 Then
    .Cells(1, 1) = "Art. Nr."
    .Cells(1, 2) = "Spaltenbezeichnung"
    .Cells(1, 3) = "Neuer Wert"
    .Cells(1, 4) = "Alter Wert"
    .Range("A1:D1").Font.Bold = True
    .Range(.Cells(2, 1), .Cells(lngN + 1, 4)) = vNew
    
    For lngR = 1 To lngN
      
      .Hyperlinks.Add Anchor:=.Cells(lngR + 1, 1), _
        Address:="", _
        SubAddress:=vLink(lngR, 1)
      
      If vLink(lngR, 2) <> "" Then .Hyperlinks.Add Anchor:=.Cells(lngR + 1, 3), _
        Address:="", _
        SubAddress:=vLink(lngR, 2)
    Next
    
    .Range(.Cells(2, 1), .Cells(lngN + 1, 4)).Sort Key1:=.Cells(2, 1), _
      key2:=.Cells(2, 2), _
      Header:=xlNo
  Else
    .Cells(1, 1) = "Keine Abweichungen vorhanden!"
  End If
  .Columns.AutoFit
End With

ErrExit:

If Err Then
  MsgBox Err.Number & vbLf & Err.Description, 64, "PROTOKOLL - FEHLER"
  Err.Clear
Else
  MsgBox "Datenvergleich erfolgreich abgeschlossen!" & Space(15) & vbLf & vbLf & _
    "Es wurden " & CStr(lngN) & " Änderungen Protokolliert!", 64, "PROTOKOLL"
End If

Application.StatusBar = False
Set objSrc = Nothing
Set objTar = Nothing
Set objWB = Nothing
Set objSh = Nothing

GetMoreSpeed 0

End Sub



Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub


Private Function FindInArray(ByVal find As Variant) As Long
Dim l As Long

FindInArray = -1


For l = LBound(vCom) To UBound(vCom)
  If vCom(l, 1) = find Then
    FindInArray = l
    Exit Function
  End If
Next


End Function


Gruß Sepp

Anzeige
AW: Schneller
18.08.2006 08:16:13
Melanie
Hi Sepp!
Boa, das ist ja der absolute Wahnsinn - kannst Du Gedanken lesen? Ich habe heute morgen vor dem Problem gestanden, dass die neuen Artikel nicht erkannt werden und das Makro abbricht. Dann habe ich mal vorsichtig versucht Deinen Code zu verstehen (was mir bislang nicht geglückt ist, aber ich hoffe, dass ich das noch schaffen werde). Und dann gucke ich in meinen Briefkasten und sehe: Du hast das Makro zur Perfektion gebracht. WOW!
HERZLICHEN DANK!!!!
Jetzt gibt es noch eine einzige Verbesserung, die ich dann hoffentlich selber hinbekomme. Und zwar möchte ich noch die Inhalte aus bestimmten Spalten IMMER im Änderungsprotokoll eintragen, damit ich prüfen kann, ob auch die erforderlichen "Folge-Änderungen" in den anderen Abteilungen vorgenommen wurden.
Viele dankbare Grüße!!!!
Melanie
Anzeige
AW: Schneller
18.08.2006 09:18:25
Melanie
Hallo Sepp,
noch zwei "kleine" Fragen:
wenn ich den Code jetzt über meine 51.000 Zeilen laufen lasse, kommt am Ende die Meldung, "Protokoll-Fehler: 1004 Anwendungs- oder objektdefinierter Fehler".
Die Datensätze werden alle durchsucht, es findet kein Abbruch statt (Ausnahme: der Eintrag #WERT erscheint als "Typenfehler").
und die zweite:
kann ich bestimmte Spalten, z.B. die Bestandsmenge, von dem Vergleich ausschließen, da hier ja immer Änderungen auftreten?
Ach, und noch etwas:
kann es sein, dass ein Indexfehler auftaucht, wenn zu viele Fehler (größer 64000) gefunden werden? Ich hatte einen Programmabbruch in Zeile 37869, konnte aber in der Zeile der aktuellen und der Vergleichsmappe nichts Auffälliges finden. Als ich den Suchbereich von A1:BM auf A1:BC geändert habe, ist alles durchgelaufen (allerdings mit dem Ergebnis der 1. Frage = Protokollfehler 1004).
Einen lieben Gruß,
Melanie
Anzeige
AW: Schneller
18.08.2006 09:39:10
Gerd
Hallo Melanie,
ich habe nicht den ganzen Thread gelesen.
Zur letzten Frage (aus der Hilfe- Datentypen):
Integer 2 Bytes -32.768 bis 32.767
Long
(lange Ganzzahl) 4 Bytes -2.147.483.648 bis 2.147.483.647
Gruß
Gerd
Sensationell, danke o.T.
19.08.2006 01:30:40
Sigi
ot
Protokoll mehr als 65000 Zeilen
18.08.2006 20:24:02
Melanie
Hallo zusammen, hallo Sepp
nach umfangreichen Abschlusstests habe ich nun noch zwei Fragen zum "letzten Schliff":
1. wenn das Protokoll mehr als 65xxx Zeilen enthält bricht das Programm ab mit einem Indexfehler. Gibt es eine Möglichkeit zu sagen: wenn Du mehr als 65xxx Zeilen hast, dann schreibe die in das erste Tabellenblatt und für den Rest machst Du ein neues Tabellenblatt auf?
2. ich habe noch Probleme mit dem Vergleich von Datumsfeldern.
Obwohl die Datumsfelder "eigentlich" gleich formatiert sind (wird über Makro formatiert und sollte deshalb gleich sein), erkennt das Programm die Daten als "unterschiedlich" und schreibt sie in das Änderungsprotokoll, obwohl sie identisch sind. Hast Du/Habt ihr eine Idee?
Gruß,
Melanie
Anzeige
AW: Protokoll mehr als 65000 Zeilen
19.08.2006 11:24:28
Josef
Hallo Melanie!
Ich hab den Code angepasst.
Das geht aber nur auf Kosten der Geschwingigkeit!
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
Private vCom As Variant

Sub CompareAndReport()
Dim objWB As Workbook
Dim objSh As Worksheet, objSrc As Worksheet, objTar As Worksheet
Dim strFile As String, strDate As String
Dim lngR As Long, lngN As Long, lngI As Long, lngK As Long, lngM As Long, intC As Integer, shtCount As Integer
Dim vVal1 As Variant, vVal2 As Variant, vNew() As Variant, vLink() As Variant
Dim value1 As Variant, value2 As Variant

On Error GoTo ErrExit
GetMoreSpeed

Application.StatusBar = "Datenvergleich - Lese Daten - Bitte warten!"

strFile = "F:\Temp\Vergleich\Datei2.xls" ' Die zu vergleichende Datei! - Anpassen!

strDate = Format(Now, "dd_mm_yy hhmmss")

Set objWB = Workbooks.Open(strFile)

Set objTar = objWB.Sheets("Tabelle1") ' Tabellenname anpassen (Vergleichende!)

With objTar
  vVal2 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
  vCom = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

objWB.Close False

Set objSrc = ThisWorkbook.Sheets("Tabelle1") ' Tabellenname anpassen (Diese Datei)

With objSrc
  vVal1 = .Range("A1:BM" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With

Redim vNew(1 To Rows.Count, 1 To 4)
Redim vLink(1 To Rows.Count, 1 To 2)

For lngR = 2 To UBound(vVal1, 1)
  Application.StatusBar = "Datenvergleich - [ " & Format(lngR / UBound(vVal1, 1), "0 %") & " ] - Bitte warten!"
  lngI = FindInArray(vVal1(lngR, 1))
  If lngI > -1 Then
    For intC = 2 To UBound(vVal1, 2)
      Select Case intC
        Case 8, 12, 17 'Spalten die NICHT durchsucht werden sollen! - Anpassen!
        Case Else
          value1 = Trim(vVal1(lngR, intC))
          value2 = Trim(vVal2(lngI, intC))
          If IsNumeric(value1) Then value1 = CDbl(value1)
          If IsNumeric(value2) Then value2 = CDbl(value2)
          If value1 <> value2 Then
            lngN = lngN + 1
            vNew(lngN, 1) = vVal1(lngR, 1)
            vNew(lngN, 2) = vVal1(1, intC)
            vNew(lngN, 3) = vVal1(lngR, intC)
            vNew(lngN, 4) = vVal2(lngI, intC)
            vLink(lngN, 1) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
            vLink(lngN, 2) = "'" & objSrc.Name & "'!" & Cells(lngR, intC).Address(0, 0)
          End If
      End Select
      If (lngN + 1) Mod (Rows.Count - 1) = 0 Then GoTo NewSheet
      ResSheet:
    Next
  Else
    lngN = lngN + 1
    vNew(lngN, 1) = vVal1(lngR, 1)
    vNew(lngN, 2) = "NEU"
    vLink(lngN, 1) = "'" & objSrc.Name & "'!" & Cells(lngR, 1).Address(0, 0)
    If (lngN + 1) Mod (Rows.Count - 1) = 0 Then GoTo NewSheet
  End If
Next

Application.StatusBar = "Datenvergleich - Erstelle Protokoll - Bitte warten!"

NewSheet:

If lngN > 0 Then
  
  With ThisWorkbook
    Set objSh = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
  End With
  
  objSh.Name = "Protokoll " & strDate & IIf(shtCount > 0, " (" & CStr(shtCount) & ")", "")
  
  With objSh
    .Cells(1, 1) = "Art. Nr."
    .Cells(1, 2) = "Spaltenbezeichnung"
    .Cells(1, 3) = "Neuer Wert"
    .Cells(1, 4) = "Alter Wert"
    .Range("A1:D1").Font.Bold = True
    .Range(.Cells(2, 1), .Cells(lngN + 1, 4)) = vNew
    
    For lngK = 1 To lngN
      
      .Hyperlinks.Add Anchor:=.Cells(lngK + 1, 1), _
        Address:="", _
        SubAddress:=vLink(lngK, 1)
      
      If vLink(lngK, 2) <> "" Then .Hyperlinks.Add Anchor:=.Cells(lngK + 1, 3), _
        Address:="", _
        SubAddress:=vLink(lngK, 2)
    Next
    
    .Range(.Cells(2, 1), .Cells(lngN + 1, 4)).Sort Key1:=.Cells(2, 1), _
      key2:=.Cells(2, 2), _
      Header:=xlNo
    .Columns.AutoFit
  End With
  lngM = lngM + lngN
  lngN = 0
  shtCount = shtCount + 1
  GoTo ResSheet
Else
  If shtCount = 0 Then MsgBox "Keine Abweichungen vorhanden!"
End If


ErrExit:

If Err Then
  MsgBox Err.Number & vbLf & Err.Description, 64, "PROTOKOLL - FEHLER"
  Err.Clear
Else
  MsgBox "Datenvergleich erfolgreich abgeschlossen!" & Space(15) & vbLf & vbLf & _
    "Es wurden " & CStr(lngM) & " Änderungen Protokolliert!", 64, "PROTOKOLL"
End If

Application.StatusBar = False
Set objSrc = Nothing
Set objTar = Nothing
Set objWB = Nothing
Set objSh = Nothing

GetMoreSpeed 0

End Sub



Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub


Private Function FindInArray(ByVal find As Variant) As Long
Dim l As Long

FindInArray = -1

For l = LBound(vCom) To UBound(vCom)
  If vCom(l, 1) = find Then
    FindInArray = l
    Exit Function
  End If
Next


End Function


Gruß Sepp

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige