MacNOMODO

Où on cause du Mac - A consommer sans modération

 
PortailPortailAccueilRechercherRechercherFAQS'enregistrerMembresConnexion

Partagez | 
 

 Excel :: comparer deux tableaux

Voir le sujet précédent Voir le sujet suivant Aller en bas 
AuteurMessage
TG
Légende vivante
Légende vivante
avatar

Nombre de messages : 5529
Age : 54
Planète : Paradis n°2
Matos : MacBook Pro Unibody 2.54 late 2008 Mountain Lion • MacPlus • PIXMA iP4300 • Scanner Epson Photo 330
Date d'inscription : 12/11/2006

MessageSujet: Excel :: comparer deux tableaux   12/3/2006, 23:17

On a souvent besoin de comparer un tableau Excel a un autre (une sauvegarde faite quelques jours avant, par exemple) pour voir les différences ou les changements.

Voici une macro qui fait le travail :
Code:
Sub Comparer()
    Dim file1
    Dim file2
    Dim tab1
    Dim tab2
    Dim W1 As Workbook
    Dim W2 As Workbook
    Dim W3 As Workbook
    Dim x
    Dim comp

    'file1 = Application.GetOpenFilename("Fichier Excel (*.XLS),*.XLS", , "Fichier de référence pour la comparaison", , False)'PC
    file1 = Application.GetOpenFilename("XLS4,XLS8", , "Fichier de référence pour la comparaison", , False) 'Mac
    If file1 <> False Then
        'file2 = Application.GetOpenFilename("Fichier Excel (*.XLS),*.XLS", , "Fichier candidat pour la comparaison", , False)'PC
        file2 = Application.GetOpenFilename("XLS4,XLS8", , "Fichier candidat pour la comparaison", , False) 'Mac
        If file2 <> False Then
            Set W1 = Workbooks.Open(file1, False, True, , "", "", True)
            i = 0
            For Each o In W1.Sheets
                i = i + 1
                S1 = S1 & i & " : " & o.Name & Chr(13)
            Next
            tab1 = 0
            While tab1 < 1 Or tab1 > W1.Sheets.Count
                tab1 = ""
                While Not IsNumeric(tab1)
                    tab1 = InputBox(S1, "Quel onglet dans le fichier de référence ?", 1)
                Wend
                tab1 = Val(tab1)
            Wend
            If file1 <> file2 Then
                Set W2 = Workbooks.Open(file2, False, True, , "", "", True)
            Else
                Set W2 = W1
            End If
            i = 0
            For Each o In W2.Sheets
                i = i + 1
                S2 = S2 & i & " : " & o.Name & Chr(13)
            Next
            tab2 = 0
            While tab2 < 1 Or tab2 > W2.Sheets.Count
                tab2 = ""
                While Not IsNumeric(tab2)
                    tab2 = InputBox(S2, "Quel onglet dans le fichier candidat ?", 1)
                Wend
                tab2 = Val(tab2)
            Wend
            Application.Interactive = False
            Application.ScreenUpdating = False
            x = InputBox("1 : rouge" & Chr(13) & "2 : cadre rouge" & Chr(13) & "3 : 1 et 2", "Type de mise en valeur", 1)
            If Not IsNumeric(x) Then x = "3"
            If x < "1" Then x = "1"
            If x > "3" Then x = "3"
            x = Val(x)
            Application.DisplayAlerts = False
            Set W3 = Workbooks.Add()
            While W3.Sheets.Count > 1
                W3.Sheets(1).Delete
            Wend
            W1.Sheets(tab1).Copy before:=W3.Sheets(W3.Sheets.Count)
            W2.Sheets(tab2).Copy before:=W3.Sheets(W3.Sheets.Count)
            W3.Sheets(2).Copy before:=W3.Sheets(W3.Sheets.Count)
            W3.Sheets(2).Copy before:=W3.Sheets(W3.Sheets.Count)
            W3.Sheets(1).Name = Left("Référence (" & W1.Name & ")", 31)
            W3.Sheets(2).Name = Left("Candidat (" & W2.Name & ")", 31)
            W3.Sheets(3).Name = "Comparaison"
            W3.Sheets(4).Name = "Ecarts"
            W1.Close False
            If file1 <> file2 Then
                W2.Close False
            End If
            W3.Sheets(W3.Sheets.Count).Delete
            Application.DisplayAlerts = True
            With W3.Sheets("Ecarts").Cells
                .ClearContents
                .Font.Color = RGB(200, 200, 200)
            End With
            If x = 3 Then W3.Sheets("Comparaison").Cells.Font.Color = RGB(200, 200, 200)
            For c = 1 To W3.Sheets("Comparaison").Cells(1).SpecialCells(xlCellTypeLastCell).Column
                For l = 1 To W3.Sheets("Comparaison").Cells(1).SpecialCells(xlCellTypeLastCell).Row
                    On Error Resume Next
                    comp = (W3.Sheets(1).Cells(l, c) <> W3.Sheets(2).Cells(l, c))
                    If Err.Number > 0 Then
                        comp = True
                    End If
                    On Error GoTo 0
                    If comp Then
                        With W3.Sheets("Comparaison").Cells(l, c)
                            If x = 1 Or x = 3 Then .Font.Color = RGB(255, 0, 0)
                            If x = 2 Or x = 3 Then .Borders.Color = RGB(255, 0, 0)
                            If x = 2 Or x = 3 Then .Borders.Weight = xlThick
                        End With
                        With W3.Sheets("Ecarts").Cells(l, c)
                            .Font.Color = RGB(255, 0, 0)
                            If IsNumeric(W3.Sheets(2).Cells(l, c)) And IsNumeric(W3.Sheets(1).Cells(l, c)) Then
                                .Value = W3.Sheets(2).Cells(l, c) - W3.Sheets(1).Cells(l, c)
                                .NumberFormat = "+ General;- General"
                            Else
                                .Value = W3.Sheets(2).Cells(l, c)
                            End If
                        End With
                    Else
                        If IsNumeric(W3.Sheets(2).Cells(l, c)) Then
                            W3.Sheets("Ecarts").Cells(l, c) = 0
                        Else
                            W3.Sheets("Ecarts").Cells(l, c) = W3.Sheets(2).Cells(l, c)
                        End If
                    End If
                Next
            Next
            W3.Sheets("Comparaison").Activate
            Application.Interactive = True
            Application.ScreenUpdating = True
        End If
    End If
End Sub

L'idéal est de placer ce code derrière un bouton lui-même placé dans la première feuille d'un classeur qu'on enregistrera sous le nom de comparerDeuxTableaux.xls ou un truc dans le genre.

Si une bonne âme veut s'attaquer au portage de ça sur OOo ou NeoO...
Revenir en haut Aller en bas
http://www.panoramio.com/user/616684
TG
Légende vivante
Légende vivante
avatar

Nombre de messages : 5529
Age : 54
Planète : Paradis n°2
Matos : MacBook Pro Unibody 2.54 late 2008 Mountain Lion • MacPlus • PIXMA iP4300 • Scanner Epson Photo 330
Date d'inscription : 12/11/2006

MessageSujet: Fichier tout fait à télécharger   12/6/2006, 00:14

Revenir en haut Aller en bas
http://www.panoramio.com/user/616684
 
Excel :: comparer deux tableaux
Voir le sujet précédent Voir le sujet suivant Revenir en haut 
Page 1 sur 1

Permission de ce forum:Vous ne pouvez pas répondre aux sujets dans ce forum
MacNOMODO :: I n f o s :: Conseils, trucs & astuces-
Sauter vers: