Tabellenabgleich mit Formatierung der Unterschiede

Sub Burghard() Dim wS1 As Worksheet, wS2 As Worksheet, _ sT As String, _ i As Long, j As Long, laR1 As Long, laR2 As Long Application.ScreenUpdating = False Set wS1 = Sheets("Tabelle1") Set wS2 = Sheets("Tabelle2") With wS1 laR1 = .Cells(Rows.Count, 1).End(xlUp).Row For i = laR1 To 2 Step -1 sT = .Cells(i, 1).Text & .Cells(i, 2).Text _ & .Cells(i, 3).Text & .Cells(i, 4).Text laR2 = wS2.Cells(Rows.Count, 1).End(xlUp).Row For j = laR2 To 2 Step -1 If sT = wS2.Cells(j, 1).Text & wS2.Cells(j, 2).Text _ & wS2.Cells(j, 3).Text & wS2.Cells(j, 4).Text Then .Rows(i).Delete wS2.Rows(j).Delete Exit For End If Next j Next i End With With wS2 laR2 = .Cells(Rows.Count, 1).End(xlUp).Row For i = laR2 To 2 Step -1 sT = .Cells(i, 1).Text & .Cells(i, 2).Text _ & .Cells(i, 3).Text & .Cells(i, 4).Text laR1 = wS1.Cells(Rows.Count, 1).End(xlUp).Row For j = laR1 To 2 Step -1 If sT = wS1.Cells(j, 1).Text & wS1.Cells(j, 2).Text _ & wS1.Cells(j, 3).Text & wS1.Cells(j, 4).Text Then .Rows(i).Delete wS1.Rows(j).Delete Exit For End If Next j Next i End With Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Catie!
Probier mal!

' **********************************************************************
' Modul: mdlDateivergleich Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
  Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) _
  As Long

Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  Flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Private Const OFN_FILEMUSTEXIST As Long = &H1000&
Private Const OFN_HIDEREADONLY As Long = &H4&
Private Const OFN_PATHMUSTEXIST As Long = &H800&

Private Function ShowOpen(Path As String, Filter As String, Flags As Long, hWnd As _
  Long, Optional FilterIndex As Long = 1&, Optional Title As String = "Datei Auswählen") As String
Dim Buffer As String
Dim Result As Long
Dim ComDlgOpenFileName As OPENFILENAME

Buffer = String$(128, 0)

With ComDlgOpenFileName
  .lStructSize = Len(ComDlgOpenFileName)
  .hwndOwner = hWnd
  .Flags = Flags
  .nFilterIndex = FilterIndex
  .nMaxFile = Len(Buffer)
  .lpstrFile = Buffer
  .lpstrFilter = Filter
  .lpstrInitialDir = Path
  .lpstrTitle = Title


End With

Result = GetOpenFileName(ComDlgOpenFileName)

If Result <> 0 Then
  ShowOpen = Left$(ComDlgOpenFileName.lpstrFile, _
    InStr(ComDlgOpenFileName.lpstrFile, _
    Chr$(0)) - 1)
End If
End Function

Private Function Datei_Waehlen(strMsg As String) As String
Dim Filter As String
Dim Flags As Long

Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
  OFN_PATHMUSTEXIST

Filter = "Alle Dateien (*.*)" & Chr$(0) & "*.*" & Chr$(0) & _
  "Excel Dateien (*.xls, *.xla, *.xlt, *.csv)" & Chr$(0) & _
  "*.xls; *.xla; *.xlt; *.csv" & Chr$(0) & Chr$(0)

Datei_Waehlen = ShowOpen("C:", Filter, Flags, 0, 2&, strMsg)

End Function

Sub vergleichMatrix()
'by Josef Ehrensberger
Dim arr1 As Variant
Dim arr2 As Variant
Dim objWb1 As Workbook, objWb2 As Workbook, objWb As Workbook
Dim wks1 As Worksheet, wks2 As Worksheet
Dim strRange As String, strFile1 As String, strFile2 As String
Dim n As Long, m As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

strFile1 = Datei_Waehlen("1. Datei zum Vergleich wählen")

If strFile1 = "" Then GoTo ErrExit

For Each objWb In Workbooks
  If objWb.FullName = strFile1 Then
    Set objWb1 = objWb
    Exit For
  End If
Next

If objWb1 Is Nothing Then Set objWb1 = Workbooks.Open(strFile1)

strFile2 = Datei_Waehlen("2. Datei zum Vergleich wählen - hier wird gekennzeichnet!")

If strFile2 = "" Or strFile1 = strFile2 Then
  objWb1.Close False
  Set objWb1 = Nothing
  GoTo ErrExit
End If

For Each objWb In Workbooks
  If objWb.FullName = strFile2 Then
    Set objWb2 = objWb
    Exit For
  End If
Next

If objWb2 Is Nothing Then Set objWb2 = Workbooks.Open(strFile2)

Set objWb2 = GetObject(strFile2)

strRange = "A5:P40" 'Bereich der verglichen wird - anpassen

Set wks1 = objWb1.Sheets("Summary")

Set wks2 = objWb2.Sheets("Summary")

wks2.Range(strRange).Font.Bold = False
arr1 = wks1.Range(strRange)
arr2 = wks2.Range(strRange)

For m = 1 To UBound(arr1, 2)
  For n = 1 To UBound(arr1, 1)
    If arr1(n, m) <> arr2(n, m) Then
      wks2.Range(strRange).Cells(n, m).Font.Bold = True
    End If
  Next
Next

ErrExit:

objWb1.Close False

Set objWb1 = Nothing
Set objWb2 = Nothing

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

Tabellenabgleich mit Formatierung der Unterschiede

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenabgleich mit Formatierung der Unterschiede

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread