Microsoft 365 Modification d'un code VBA

desto

XLDnaute Junior
Bonsoir à tous.
je voudrais solliciter votre assistance pour la modification d'un code me servant à faire une comparaison de données sur la première colonne.
j'aimerais que vous m'indiquiez la façon dont je pourais faire la modification afin que la comparaison des deux fichiers ne soit uniquement pas sur la colonne A.
Par exemple , comment indiquer dans le code que la comparaison doit se faire sur la colonne B d'un fichier et sur la colonne E de l'autre fichier ou vice versa, comme dans les fichiers joint.
Le problème avec les fichiers joints, est que que certaines transactions qui apparaissent absente à une date, peuvent revenir à une autre date et j'aimerais pouvoir les réconcilier à chaque fois et ressortir à la fin d'une periode (Mois ou semaine) les suspens en attente.
toutes indications qui me permettront d'affiner le code dans ce sens seront les bienvenues.

Ci dessous le code :
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
 

Pièces jointes

  • CorrespPayment_51173_20220714.xlsx
    13.9 KB · Affichages: 4
  • 13072022.xls
    53.5 KB · Affichages: 2
Dernière édition:

Hasco

XLDnaute Barbatruc
Bonjour,

Je ne modifierai pas votre macro. Par contre je peux vous proposer une solution par power query.
Comme je n'ai pas bien saisi ce que vous vouliez, comment vous définissiez les "suspens en attente", de quel fichier à quel fichier va la relation, je vous ai fait un exemple simple de non correspondance.

Dans le fichier joint vous verrez 3 requêtes (onglet 'Données' bouton 'requêtes et connexions') :

Tout : importe les données du fichier "13072022.xlsx"
CorrespPayment : importe les données du fichier "CorrespPayment_51173_20220714.xlsx"
Non correspondances : contient les données de CorrespPayment qui n'ont pas d'équivalent dans Tout.
La relation et faites sur le champ PIN des deux (Les PIN de CorrespPayment qui ne sont pas dans Tout)
Les données sont affichées dans la feuille du même nom que cette dernière requête.

Important : Une cellule ($B$1) nommée 'Nom_Dossier' contient une fonction retournant le nom du dossier dans lequel se trouve son fichier (Correspondances.xlsm). Si cette cellule n'affiche pas le bon chemin pour vous, recalculer le classeur. Au pire mettez le nom du répertoire à la main dans cette cellule.
Les requêtes utilisent cette cellule pour aller chercher les fichiers.

Power Query est un outil puissant pour faire ce genre de chose. Il mérite qu'on prenne du temps pour le prendre en main.

Cordialement
 

Pièces jointes

  • Correspondances.xlsm
    28.7 KB · Affichages: 3

desto

XLDnaute Junior
Bonjour,

Je ne modifierai pas votre macro. Par contre je peux vous proposer une solution par power query.
Comme je n'ai pas bien saisi ce que vous vouliez, comment vous définissiez les "suspens en attente", de quel fichier à quel fichier va la relation, je vous ai fait un exemple simple de non correspondance.

Dans le fichier joint vous verrez 3 requêtes (onglet 'Données' bouton 'requêtes et connexions') :

Tout : importe les données du fichier "13072022.xlsx"
CorrespPayment : importe les données du fichier "CorrespPayment_51173_20220714.xlsx"
Non correspondances : contient les données de CorrespPayment qui n'ont pas d'équivalent dans Tout.
La relation et faites sur le champ PIN des deux (Les PIN de CorrespPayment qui ne sont pas dans Tout)
Les données sont affichées dans la feuille du même nom que cette dernière requête.

Important : Une cellule ($B$1) nommée 'Nom_Dossier' contient une fonction retournant le nom du dossier dans lequel se trouve son fichier (Correspondances.xlsm). Si cette cellule n'affiche pas le bon chemin pour vous, recalculer le classeur. Au pire mettez le nom du répertoire à la main dans cette cellule.
Les requêtes utilisent cette cellule pour aller chercher les fichiers.

Power Query est un outil puissant pour faire ce genre de chose. Il mérite qu'on prenne du temps pour le prendre en main.

Cordialement
Bonsoir Hasco,
je te remercie pour ton retour.
Comme je n'ai pas bien saisi ce que vous vouliez, comment vous définissiez les "suspens en attente", de quel fichier à quel fichier va la relation, je vous ai fait un exemple simple de non correspondance.
''Les suspens en attente" sont en fait des non correspondances provenant à la fois du fichier "13072022.xlsx" et du fichier "CorrespPayment_51173_20220714.xlsx", avec un accent particulier sur le fichier "13072022.xlsx" .
Ces non correspondances du fichier "13072022.xlsx" doivent ensuite être prise en compte lors d'une nouvelle compraraison de nouveaux fichiers
 

Hasco

XLDnaute Barbatruc
Re,

Et ce que j'ai fait ne va pas ?

Il faut que vous essayez de parler plus concrètement car je ne vois pas ce que vous voulez dire au juste.
des non correspondances provenant à la fois du fichier "13072022.xlsx" et du fichier "CorrespPayment_51173_20220714.xlsx"
Ci dessous A =13072022.xlsx, B = CorrespPayment_51173_20220714.xls

Cela veut-il dire que vous voulez à la fois les PIN de A absents de B et les PIN de B absents de A ?
Voir fichier joint.

avec un accent particulier sur le fichier "13072022.xlsx"

Quel accent ? Trop vague pour savoir de quoi il s'agit ?

Que fait-on des colonnes de A qui ne sont pas dans B et de B qui ne sont pas dans A.
 

Pièces jointes

  • Correspondances.xlsm
    34.3 KB · Affichages: 2

desto

XLDnaute Junior
Re,

Et ce que j'ai fait ne va pas ?

Il faut que vous essayez de parler plus concrètement car je ne vois pas ce que vous voulez dire au juste.

Ci dessous A =13072022.xlsx, B = CorrespPayment_51173_20220714.xls

Cela veut-il dire que vous voulez à la fois les PIN de A absents de B et les PIN de B absents de A ?
Voir fichier joint.



Quel accent ? Trop vague pour savoir de quoi il s'agit ?

Que fait-on des colonnes de A qui ne sont pas dans B et de B qui ne sont pas dans A.
 

desto

XLDnaute Junior
Bonjour Hasco,

Toutes mes excuses si mes explications ne sont pas bien claires.

Quel accent ? Trop vague pour savoir de quoi il s'agit ?
Ce que je voudrait dire par "accent" est que les PIN Présents dans A absent dans B soient recherchés dans un nouveaux fichier B = CorrespPayment_51173_20220715.xls et mis à jour au fur et a mesure que les journées s'ajoutent. Après chaque traitement , je me chargerai de faire la somme des montants.
Quant aux PIN Présents dans B mais absents dans A , ils seront aussi recherchés dans un nouveaux fichier qui aura par exemple pour nom "14072022.xlsx" et la liste mis à jour au fur et a mesure que les journées s'ajoutent.

Que fait-on des colonnes de A qui ne sont pas dans B et de B qui ne sont pas dans A.
J'aurai juste à les afficher afin de les utiliser dans un rapport pour présenter les détails des PIN concernés.
Voila un peu ce que je voulais dire.

Le traitement peut-il marcher sur plusiuers fichier de type A et plusieurs de type B en une seules fois ?
 

Hasco

XLDnaute Barbatruc
Re,

Power query peut interroger un dossier, en sélectionner les fichiers souhaités en extraire les données, les transformer et beaucoup d'autres choses.
Je vous ai montré un simple exemple sur la base de vos fichiers.
Maintenant à vous d'apprendre de faire et en cas de problème particulier et précis, de revenir.
Le forum, n'est qu'un simple forum de dépannage sur des points particulier d'un développement.
Nous vous donnons les techniques possibles, mais à vous de les apprendre et les appliquer.

Si power query vous paraît trop compliqué à apprendre, vous pouvez continuer avec vba, mais là non plus personne de pourra organiser les choses à votre place.

Cordialement
 

Hasco

XLDnaute Barbatruc
Re,

Si vous restez sur du VBA alors joignez des fichiers avec les macros nécessaires, les tenants et aboutissants, parce que dans votre post#1 il manque certaines choses. (prcédure "GetWBAndWS" par exemple).

cordialement
 

Discussions similaires

Réponses
1
Affichages
107

Statistiques des forums

Discussions
302 063
Messages
2 000 130
Membres
214 752
dernier inscrit
Ngardjibem