Microsoft 365 Modification d'un code VBA

Option Explicit

Public Const NoColonneTransactions = 1
Public Const NbLignesTitreTransactions = 1
Public Const CouleurSélection = 65535
Public Const CouleurDoublons = 10092492

'-----------------------------------------------------------
'Comparer les 2 listes de numéros en colonne A de 2 feuilles
'-----------------------------------------------------------
Sub ComparerTransactions()
Dim WS(1 To 2) As Worksheet
Dim RangeTableau As Range
Dim TabTransactions() As Variant
Dim DernièreLigne As Long
Dim DernièreColonne As Long
Dim i As Long
Dim Nb(1 To 2) As Long
Dim n As Long
Dim p As Long
Dim t0 As Long
Dim AddHyperlinks As Boolean
Dim S As String
Dim Réponse As Variant
Dim SortRange As Range
Dim KeyRange As Range
Dim TakeIt As Boolean
Dim IndexMajeur As Long
Dim IndexMineur As Long
Dim DernierIndexMineurTrouvé As Long

'Inhibe les évènements et les calculs
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'Tableaux des numéros de transactions
ReDim TabTransactions(1 To 2)

'Ouvrir les feuilles à comparer
For i = 1 To 2
GoSub ChargerFeuillesAComparer
Next i

'Vérification feuilles différentes
If WS(1).Parent.Name = WS(2).Parent.Name _
And WS(1).Name = WS(2).Name Then
MsgBox "La comparaison ne peut s'appliquer à une seule et même feuille !"
Exit Sub
End If

'Inhibe l'affichage
Application.ScreenUpdating = False

With ThisWorkbook
'Effacement des feuilles présentes
On Error Resume Next
Application.DisplayAlerts = False
For i = 1 To 2
.Worksheets(2).Delete
Next i
Application.DisplayAlerts = True
On Error GoTo 0
End With

'Recopie des feuilles sources dans ce classeur
For i = 1 To 2
GoSub CopierFeuillesAComparer
Next i

'Active la feuille 1ère feuille copiée
Windows(ThisWorkbook.Name).Activate
ThisWorkbook.Activate
WS(1).Activate

'Désinhibe l'affichage
Application.ScreenUpdating = True
DoEvents

Réponse = MsgBox("Ajouter les hyperliens pour les ""Trouvés"" (traitement plus long) ?", vbYesNoCancel + vbQuestion + vbDefaultButton2)
If Réponse = vbCancel Then Exit Sub
If Réponse = vbYes Then AddHyperlinks = True
Call ClearMsgBox

'Initialisation du timer
t0 = Timer

'Inhibe l'affichage
Application.ScreenUpdating = False

'Comparaison des tableaux des numéros de transactions
For i = 1 To 2
GoSub CompareTabTransactions
Next i

'Création du nom et de la MFC gérant le surlignage de la sélection
For i = 1 To 2
GoSub CréerNomEtMFC
Next i

'Mettre un filtre sur le colonne Statut de rapprochement
For i = 1 To 2
GoSub AjouterFiltres
Next i

WS(1).Activate

'Désinhibe l'affichage
Application.ScreenUpdating = True

'Désinhibe es évènements et les calculs
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "Terminé " & Int(Timer - t0) & " secondes."
Exit Sub

'-------------------------------------------------
'Sub interne de chargement des feuilles à comparer
'-------------------------------------------------
ChargerFeuillesAComparer:

'Ouverture de la feuille à comparer
Set WS(i) = GetWBAndWS("comparer les transactions (" & IIf(i = 1, "1ère", "2ème") & " feuille)", WSInitiale:=ActiveSheet)
If WS(i) Is Nothing Then Exit Sub

DernièreLigne = DernièreLigneEnColonne(WS(i).Columns(NoColonneTransactions))
If DernièreLigne <= NbLignesTitreTransactions Then
MsgBox "Cette feuille ne comporte aucune ligne transaction !"
Exit Sub
End If
Return

'-------------------------------------------------------------
'Sub interne de copie des feuilles à comparer dans ce classeur
'-------------------------------------------------------------
CopierFeuillesAComparer:

'Recopie des feuilles sources dans ce classeur
WS(i).Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

'Nomme la feuille avec le nom du classeur (hors extension) et de la feuille (limite 31 caractères)
S = WS(i).Parent.Name
If InStrRev(S, ".") > 0 Then S = Left(S, InStrRev(S, ".") - 1)
S = Left(S, 30 - Len(WS(i).Name)) & "~" & WS(i).Name

Set WS(i) = ActiveSheet
WS(i).Name = S

'Supprimer les filtres
If WS(i).AutoFilterMode Then ActiveSheet.AutoFilterMode = False

'Nombre de lignes
DernièreLigne = DernièreLigneEnColonne(WS(i).Columns(NoColonneTransactions))
Nb(i) = DernièreLigne - NbLignesTitreTransactions

'Mise en numérique des valeurs dans le tableau
TabTransactions(i) = WS(i).Cells(NbLignesTitreTransactions + 1, NoColonneTransactions).Resize(Nb(i)).Value

For n = 1 To Nb(i)
If IsNumeric(TabTransactions(i)(n, 1)) Then
TabTransactions(i)(n, 1) = CDbl(TabTransactions(i)(n, 1))
Else
TabTransactions(i)(n, 1) = 0
End If
Next n

WS(i).Cells(NbLignesTitreTransactions + 1, NoColonneTransactions).Resize(Nb(i)).Value = TabTransactions(i)

'Tri de la feuille sur la colonne Transactions
With WS(i)
Set SortRange = .UsedRange
Set KeyRange = SortRange.Offset(NbLignesTitreTransactions).Resize(SortRange.Rows.Count - NbLignesTitreTransactions, 1)

With .Sort
.SortFields.Clear
.SortFields.Add Key:=KeyRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange SortRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With

'Chargement des valeurs en tableau après tri
TabTransactions(i) = WS(i).Cells(NbLignesTitreTransactions + 1, NoColonneTransactions).Resize(Nb(i)).Value

'Insertion de la colonne Statut de rapprochement
WS(i).Columns(1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
WS(i).Columns(1).ColumnWidth = 17

'Format du titre de la colonne Statut de rapprochement
With WS(i).Cells(1, 1)
.Font.Name = "Biome Light"
.Font.Size = 10
.Font.Bold = True
.Font.ThemeColor = xlThemeColorDark1
.Interior.Color = 5296274
.WrapText = True
.HorizontalAlignment = xlCenter
.FormulaLocal = "=" & """Rapprochement"" & CAR(10) & SOUS.TOTAL(3;$A$" & NbLignesTitreTransactions + 1 & ":$A$" & Rows.Count & ")"
.Rows.AutoFit
End With

'Format des cellules de la colonne Statut de rapprochement
With WS(i).Cells(NbLignesTitreTransactions + 1, 1).Resize(Nb(i))
.Interior.Color = RGB(255, 230, 153)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
Return

'-------------------------------------------------------------------
'Sub interne de comparaison des tableaux des numéros de transactions
'-------------------------------------------------------------------
CompareTabTransactions:

'Comparaison Transactions 1 et 2 ou 2 et 1
If i = 1 Then
IndexMajeur = 1
IndexMineur = 2
Else
IndexMajeur = 2
IndexMineur = 1
End If

DernierIndexMineurTrouvé = 0

For n = 1 To Nb(IndexMajeur)
TakeIt = False

For p = DernierIndexMineurTrouvé + 1 To Nb(IndexMineur)
If TabTransactions(IndexMajeur)(n, 1) > TabTransactions(IndexMineur)(p, 1) Then
'Do nothing
ElseIf TabTransactions(IndexMajeur)(n, 1) = TabTransactions(IndexMineur)(p, 1) Then
DernierIndexMineurTrouvé = p
TakeIt = True
Exit For
ElseIf TabTransactions(IndexMajeur)(n, 1) < TabTransactions(IndexMineur)(p, 1) Then
Exit For
End If
Next p

With WS(IndexMajeur)
If TakeIt Then
If AddHyperlinks Then
.Hyperlinks.Add Anchor:=.Cells(NbLignesTitreTransactions + n, 1), Address:="", _
SubAddress:="'" & WS(IndexMineur).Name & "'!" & ColumnConvertToLetters(1 + NoColonneTransactions) & _
NbLignesTitreTransactions + p, TextToDisplay:="Trouvée"
Else
.Cells(NbLignesTitreTransactions + n, 1).Value = "Trouvée"
End If
Else
.Cells(NbLignesTitreTransactions + n, 1).Value = "Absente"
End If
End With

UserForm_BarreProgression.BarreProgression Nb(IndexMajeur) + Nb(IndexMineur), (IndexMajeur - 1) * Nb(1) + n
Next n
Return

'-------------------------------------------------------------
'Sub interne de création du nom en gestionnaire de nom et de
'la MFC pour gérer la mise en couleur de la ligne sélectionnée
'et la MFC des doublons
'-------------------------------------------------------------
CréerNomEtMFC:

With WS(i)
DernièreLigne = DernièreLigneEnColonne(.Columns(1))
DernièreColonne = DernièreColonneEnLigne(.Rows(1))
Set RangeTableau = .Cells(NbLignesTitreTransactions + 1, 1).Resize(DernièreLigne - NbLignesTitreTransactions, DernièreColonne)

'MFC de sélection
Call LineSelectionHighLight_AddRange(RangeTableau, SelectionColor:=CouleurSélection)

'MFC des doublons
With .Columns(1 + NoColonneTransactions)
.FormatConditions.AddUniqueValues
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).DupeUnique = xlDuplicate
.FormatConditions(1).StopIfTrue = True
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = CouleurDoublons
.TintAndShade = 0
End With
End With
End With
Return

'------------------------------------------------------------
'Sub interne d'ajout du filtre sur le Statut de rapprochement
'------------------------------------------------------------
AjouterFiltres:

With WS(i)
'C'est compliqué les filtres (tenir compte de la présence éventuelle d'un tableau structuré filtré !)
If .AutoFilterMode Then
.AutoFilterMode = False
On Error Resume Next
.Cells.AutoFilter
If Err Then .Columns(1).AutoFilter
On Error GoTo 0
Else
.Columns(1).AutoFilter
End If
End With

'Active le classeur au cas où l'utilisateur serait sur une autre application
Windows(ThisWorkbook.Name).Activate
ThisWorkbook.Activate
WS(i).Activate

'Gestion du split
With ActiveWindow
.SplitColumn = 2
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Return
End Sub

'----------------------------------------------------
'Force l'effacement d'un MsgBox lorsque un traitement
'CPU ou ScreenUpdating = False long suit sa réponse
'----------------------------------------------------
Sub ClearMsgBox()
Dim i As Integer

For i = 1 To 1000
DoEvents
Next i
End Sub

'------------------------------------------
'Conversion du numéro de colonne en lettres
'------------------------------------------
Public Function ColumnConvertToLetters(ByVal ColumnNumber As Integer) As String
Dim Ret As String

While ColumnNumber > 0
Ret = Chr(((ColumnNumber + 25) Mod 26) + 1 + 64) & Ret
ColumnNumber = Int((ColumnNumber - 1) / 26)
Wend

ColumnConvertToLetters = Ret
End Function

Cliquez pour agrandir...