Question sur une macro VBA Excel
BigEarl
Messages postés
2
Date d'inscription
Statut
Membre
Dernière intervention
-
BigEarl Messages postés 2 Date d'inscription Statut Membre Dernière intervention -
BigEarl Messages postés 2 Date d'inscription Statut Membre Dernière intervention -
Bonjour à toutes et à tous,
en surfant sur la toile, j'ai trouvé une macro très utile pour mon travail, que j'ai au préalable légèrement modifié:
Cependant, j'aimerais pouvoir effectuer plusieurs modifications, comme par exemple afficher la cellule en rouge s'il y a bien une différence.
Mes capacités en codage sont très limitées...
Merci d'avance!
en surfant sur la toile, j'ai trouvé une macro très utile pour mon travail, que j'ai au préalable légèrement modifié:
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 Sub ApplyCompareWorksheets() ' compare two different worksheets in two different workbooks CompareWorksheets ActiveWorkbook.Worksheets("Sales Master"), _ Workbooks("Discount Matrix April 2011 - Copie.xls").Worksheets("Sales Master") End Sub
Cependant, j'aimerais pouvoir effectuer plusieurs modifications, comme par exemple afficher la cellule en rouge s'il y a bien une différence.
Mes capacités en codage sont très limitées...
Merci d'avance!
A voir également:
- Question sur une macro VBA Excel
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Liste déroulante excel - Guide
- Déplacer une colonne excel - Guide
- Word et excel gratuit - Guide
- Comment trier par ordre alphabétique sur excel - Guide