Comparer 2 fichiers

[MJ13]

Bonjour à tous

J'ai cette macro en VBA qui permet de compter la somme des valeurs d'une feuille. Mais si j'ai des formules avec des erreurs, cela bug.

Comment puis-je compter la somme des valeurs sans les erreurs

Merci d'avance .

Set myRange = Workbooks(NW1).Worksheets(i).Range("A1:IU65536")
T = Application.WorksheetFunction.Sum(myRange)

NW1 est le nom du classeur et i est le numéro de la feuille du classeur.

 

[pierrejean]

Re : Compter la somme totale d'une feuille sans les erreurs

RE

Une proposition tournant chez moi en 20 secondes pour 2 fichiers de 6 feuilles chacun ,chaque feuille comportant environ 3 500 000 valeurs

Sub Compare_2_fichiers_b()
debut = Timer
NWC = ThisWorkbook.Name 'Name Workbook Comparaison
'Stop
'On Error Resume Next
Cells.Clear
Dim NW1S(1000), NW2S(1000)
FirstLig = 3
For i = 1 To 2
ActiveWindow.ActivateNext
'Affiche toutes les feuilles Classeur1
nc = ActiveWorkbook.Sheets.Count
For n = 1 To nc
Sheets(n).Visible = True
Next
NW1 = ActiveWorkbook.Name
NW1P = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWindow.ActivateNext
'Affiche toutes les feuilles Classeur2
nc = ActiveWorkbook.Sheets.Count
For n = 1 To nc
Sheets(n).Visible = True
Next
NW2 = ActiveWorkbook.Name
NW2P = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWindow.ActivateNext
If ActiveWorkbook.Name = NWC Then GoTo suite Else MsgBox "Vous devez fermer les fichiers non utiles": End
Next
suite:
'MsgBox "Comparaison " & NW1 & " et " & NW2
Cells(2, 1) = "Comparaison " & NW1 & " et " & NW2
Cells(3, 1) = NW1P: Cells(3, 2) = NW1
Cells(3, 3) = NW2P: Cells(3, 4) = NW2
For i = 1 To Workbooks(NW1).Worksheets.Count
NW1S(i) = Workbooks(NW1).Worksheets(i).Name
'Set myRange = Workbooks(NW1).Worksheets(i).Range("A1:IU65536").SpecialCells(xlCellTypeFormulas, xlNumbers)
myrange = Workbooks(NW1).Worksheets(i).Range("A1").CurrentRegion
For n = LBound(myrange, 1) To UBound(myrange, 1)
 For m = LBound(myrange, 2) To UBound(myrange, 2)
 On Error Resume Next
   t = t + myrange(n, m)
 On Error GoTo 0
Next
Next
Cells(i + FirstLig, 1) = NW1S(i): Cells(i + FirstLig, 2) = t
t = 0
Next
For i = 1 To Workbooks(NW2).Worksheets.Count
NW2S(i) = Workbooks(NW2).Worksheets(i).Name
'Set myrange = Workbooks(NW2).Worksheets(i).Range("A1:IU65536")
myrange = Workbooks(NW2).Worksheets(i).Range("A1").CurrentRegion
For n = LBound(myrange, 1) To UBound(myrange, 1)
 For m = LBound(myrange, 2) To UBound(myrange, 2)
 On Error Resume Next
   t = t + myrange(n, m)
 On Error GoTo 0
Next
Next
Cells(i + FirstLig, 3) = NW2S(i): Cells(i + FirstLig, 4) = t
t = 0
Next
MsgBox (Timer - debut)
End Sub

 

[MJ13]

Re : Compter la somme totale d'une feuille sans les erreurs

Re , Bonjour Pierre-Jean

Merci pour cette version qui me paraît bien. En plus avec les tableaux, cela paraît performant, comme ton test sur un gros fichier .

Mais le problème est que si j'ai une feuille Blanche ou qu'avec du texte, cela bug .

Bon Week-end .

 

[Staple1600]

Re : Compter la somme totale d'une feuille sans les erreurs

Bonjour le fil, les gens du fil

Retrouvé dans mes archives

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Creating the report..."
    Set rptWB = Workbooks.Add
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Worksheets(2).Delete
    Wend
    Application.DisplayAlerts = True
    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    For c = 1 To maxC
        Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
        For r = 1 To maxR
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = ws1.Cells(r, c).FormulaLocal
            cf2 = ws2.Cells(r, c).FormulaLocal
            On Error GoTo 0
            If cf1 <> cf2 Then
                DiffCount = DiffCount + 1
                Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
            End If
        Next r
    Next c
    Application.StatusBar = "Formatting the report..."
    With Range(Cells(1, 1), Cells(maxR, maxC))
        .Interior.ColorIndex = 19
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error Resume Next
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error GoTo 0
    End With
    Columns("A:IV").ColumnWidth = 20
    rptWB.Saved = True
    If DiffCount = 0 Then
        rptWB.Close False
    End If
    Set rptWB = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
        "Compare " & ws1.Name & " with " & ws2.Name
End Sub

Lancer cette macro pour tester

Sub TestCompareWorksheets()
    ' compare two different worksheets in the active workbook
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
    ' compare two different worksheets in two different workbooks
    CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
        Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub

source du code:
ERLANDSEN DATA CONSULTING

 

[MJ13]

Re : Compter la somme totale d'une feuille sans les erreurs

Bonjour JM

Merci pour le code, mais j'ai l'impression que c'est pour ma phase 3 .

 

[MJ13]

Re : Compter la somme totale d'une feuille sans les erreurs

Re à tous

Bon j'ai fait ce code qui m'a l'air un peu plus au point .

Sub Compare_2_fichiers_Phase1()
t1 = Timer
NWC = ThisWorkbook.Name 'Name Workbook Comparaison
'Stop
Dim myrange As Range
Dim NW1S(1000), NW2S(1000)
'On Error Resume Next
Range("A2:z1002").Clear
FirstLig = 3
'Affiche toutes les feuilles des classeurs
For i = 1 To 2
ActiveWindow.ActivateNext
'Affiche toutes les feuilles Classeur1
nc = ActiveWorkbook.Sheets.Count
For N = 1 To nc
Sheets(N).Visible = True
Sheets(N).Select
Next
NW1 = ActiveWorkbook.Name
NW1P = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWindow.ActivateNext
'Affiche toutes les feuilles Classeur2
nc = ActiveWorkbook.Sheets.Count
For N = 1 To nc
    Sheets(N).Visible = True
    Cells(1, 1).Select
Next
NW2 = ActiveWorkbook.Name
NW2P = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWindow.ActivateNext
'Condition avoir que les 3 fichiers pour continuer (goto suite) sinon sortie (end)
If ActiveWorkbook.Name = NWC Then GoTo suite Else MsgBox "Vous devez fermer les fichiers non utiles": End
Next
suite:
'MsgBox "Comparaison " & NW1 & " et " & NW2
Cells(2, 1) = "Comparaison " & NW1 & " et " & NW2
Cells(3, 1) = NW1P: Cells(3, 2) = NW1
Cells(3, 5) = NW2P: Cells(3, 6) = NW2
'Boucle Feuilles sur fichier 1
For i = 1 To Workbooks(NW1).Worksheets.Count
    NW1S(i) = Workbooks(NW1).Worksheets(i).Name
    Set myrange = Workbooks(NW1).Worksheets(i).Range("A1:IU65536") '.SpecialCells(xlCellTypeFormulas, xlNumbers)
    Tvide = Application.WorksheetFunction.CountBlank(myrange) 'compte vides
    TCelNonvide = Application.WorksheetFunction.CountA(myrange) 'compte Nombre de cellules remplies
    If Tvide = 16711680 Then T = 0:  GoTo suite2
    TNb_car = Application.WorksheetFunction.CountIf(myrange, "*")
    tval_sup_0 = Application.WorksheetFunction.CountIf(myrange, ">=0") ': MsgBox tval_sup_0 'CountA=nbval Sum=somme:msgbox tval_sup_0
    If tval_sup_0 > 1 Then T = tval_sup_0:  Workbooks(NW1).Activate: Sheets(i).Select: Selection.SpecialCells(xlCellTypeConstants, 1).Select: Tsum = Application.WorksheetFunction.Sum(Selection): ThisWorkbook.Activate: Cells(i + FirstLig, 4) = Tsum
suite2:
    Cells(i + FirstLig, 1) = NW1S(i): Cells(i + FirstLig, 2) = TCelNonvide: If tval_sup_0 > 0 Then Cells(i + FirstLig, 3) = T
Next
'Boucle Feuilles sur fichier 2
For i = 1 To Workbooks(NW2).Worksheets.Count
    NW2S(i) = Workbooks(NW2).Worksheets(i).Name
    Set myrange = Workbooks(NW2).Worksheets(i).Range("A1:IU65536") '.SpecialCells(xlCellTypeFormulas, xlNumbers)
    Tvide = Application.WorksheetFunction.CountBlank(myrange) 'compte vides
    TCelNonvide = Application.WorksheetFunction.CountA(myrange) 'compte Nombre de cellules remplies
    If Tvide = 16711680 Then T = 0:  GoTo suite3
    TNb_car = Application.WorksheetFunction.CountIf(myrange, "*")
    tval_sup_0 = Application.WorksheetFunction.CountIf(myrange, ">=0") ': MsgBox tval_sup_0 'CountA=nbval Sum=somme:msgbox tval_sup_0
    If tval_sup_0 > 1 Then T = tval_sup_0:  Workbooks(NW2).Activate: Sheets(i).Select: Selection.SpecialCells(xlCellTypeConstants, 1).Select: Tsum = Application.WorksheetFunction.Sum(Selection): ThisWorkbook.Activate: Cells(i + FirstLig, 8) = Tsum
suite3:
    Cells(i + FirstLig, 5) = NW2S(i): Cells(i + FirstLig, 6) = TCelNonvide: If tval_sup_0 > 0 Then Cells(i + FirstLig, 7) = T
Next
MsgBox Timer - t1
End Sub

Reste les phase 2 et 3: comparer avec couleur les noms des onglets et les tailles respectives et la phase 3: colorier pour chaque feuille diférentes les différences .

Du coup, j'ai changé le titre qui me paraît plus parlant .

 

[MJ13]

Re : Comparer 2 fichiers

Bonjour à tous

Voici la version à tester pour comparer 2 fichiers .