Documenten vergelijken en wijziging in kleur in hoofdbestand

[wilcovanee]

De oplossing volgens mij gevonden. Door regel 17 te veranderen.

van
If .Offset(nTeller, i).Font.Color = vbRed Then nUpdate = True
naar
If .Offset(nTeller, i).Font.Color = vbRed Then nUpdate = True Else GoTo vervolg

Op deze manier gaat hij, wanneer de font niet rood is naar "vervolg". In dit geval verder naar de volgende regel.

Ik ga hem nu op een aantal andere documenten testen!!

 

[Warme bakkertje]

Foutje van mij.
Wijzig deze regel

nTeller = nTeller + 1: Update = False

naar

nTeller = nTeller + 1: [COLOR="#FF0000"]n[/COLOR]Update = False

en laat de rest zoals het was.

 

[wilcovanee]

:thumb:

 

[Warme bakkertje]

Nog iets aangepaste versie, kwam uit op 17 sec. om 3 bestanden met elk +/- 25.000 regels te controleren.

Public Sub UpdateHoofdbestand()
Dim sBestand As String, sOpbouwWerkbestand As String, nUpdate As Boolean
Dim i As Integer, nTeller As Integer
sOpbouwWerkbestand = "Database 2012-*.xlsx"
Application.ScreenUpdating = False
t = Timer
sBestand = Dir(ThisWorkbook.Path & "\" & sOpbouwWerkbestand)
Do While sBestand <> ""
    Workbooks.Open ThisWorkbook.Path & "\" & sBestand
    nUpdate = False
    With Sheets("Blad 1")
        For Each cl In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
            For i = 3 To 12
                If cl.Offset(, i).Font.Color = vbRed Then nUpdate = True
            Next
            If nUpdate = True Then
                fNumber = cl.Value
                sq = cl.Offset(, 3).Resize(, 10)
                With ThisWorkbook.Sheets("Blad 1")
                    fRow = Application.Match(fNumber, .Columns(1), 0)
                    If IsError(fRow) Then MsgBox "Het nummer " & fNumber & " uit " & sBestand & " is niet gevonden in deze database !" _
                            & vbLf & vbLf & "Er zijn geen gegevens gewijzigd voor dit nummer !": GoTo vervolg
                    .Cells(fRow, 4).Resize(, 10) = sq
                End With
                cl.Offset(, 3).Resize(, 10).Font.Color = vbBlack
            End If
vervolg:
            nUpdate = False
        Next
    End With
    Workbooks(sBestand).Close True
    sBestand = Dir: nTeller = nTeller + 1
Loop
Application.ScreenUpdating = True
MsgBox "Er zijn " & Timer - t & " seconden verstreken om " & vbLf & vbLf & _
            nTeller & IIf(nTeller = 1, " werkbestand", " werkbestanden") & " te verwerken.", vbInformation, "Klaar"
End Sub