Comparaison de lignes de fichier avec insertion auto lignes pour correspond
Bonjour
je cherche à comparer dans un fichier des donnees mois-1/ mois en cours, par rubriques (dans fichier joints colonne C D E et P Q R)
si une rubrique est d'un côté et pas de l'autre je dois faire des décalages pour aligner les lignes. A part le faire à la manu, je trouve pas de solutions.
PAr avance merci :)
Bonjour,
pourriez-vous donner un exemple précis d'une ligne problématique et de ce que vous voulez obtenir à la place ?
Bonjour à tous
Doux Rêveur, ce que je comprends, c'est qu'il y a 2 blocs de données définis par la couleur de leur 1ère ligne (vert et orange), marjolaine voulant aligner chaque ligne de ces 2 blocs via les colonnes (C D E) et (P Q R).
Elle souhaite réaliser une jointure en fait.
Les 2 fichiers ont l'air identiques, ce doit être une erreur, il ne faut pas les comparer, je pense.
klin89
Salut Marjolaine,
Salut les as,
une première approche sans prétention. À toi de préciser un autre mode opératoire.
Clic sur le petit bouton rouge en [N1] fait le boulot mais ne calcule les différences que ligne par ligne sans rechercher ailleurs si des correspondances existent.
Private Sub cmdOK_Click()
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
For x = Range("A" & Rows.Count).End(xlUp).Row To 3 Step -1
If Range("P" & x).Value <> Range("C" & x).Value Or Range("Q" & x).Value <> Range("D" & x).Value Or Range("R" & x).Value <> Range("E" & x).Value Then
Range("N" & x & ":Z" & x).Insert shift:=xlShiftDown
Range("A" & x + 1 & ":M" & x + 1).Insert shift:=xlShiftDown
Range("A" & x & ":Z" & x + 1).Interior.Color = RGB(255, 255, 0)
End If
Next
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End SubA+
Bonjour Curulis
Je ne sais pas si la personne à l'origine de cette fonction de correspondance souhaitera t'interpeller sur ta remarque ' sans rechercher ailleurs si des correspondances existent', J'ai fait des recherches sur internet avec "how to synchronize same blocks in text files", mais je ne trouve rien pour m'aider à proposer une interface IHM de comparaison des blocs, Je ne vais pas ouvrir de nouvelle discussion mais les meilleurs en algorithme pourraient y voir un challenge.
Je souhaiterai être capable de trouver seul la solution qui n'ait je pense pas la problématique de Marjolaine
A tous sur le site, merci
Re le forum,
Essaie ce code :
Option Explicit
Sub alignement()
Dim a, i As Long, ii As Long, n As Long, iii As Long, txt As String, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Base").Range("a1").CurrentRegion
a = .Value2
For ii = 1 To UBound(a, 2) Step 13
For i = 3 To UBound(a, 1)
txt = Join$(Array(a(i, ii + 2), a(i, ii + 3), a(i, ii + 4)), "|")
If txt <> "" Then
If Not dico.exists(txt) Then
ReDim w(1 To UBound(a, 2))
Else
w = dico(txt)
End If
If ii = 1 Then n = 13 Else n = 12
For iii = 1 To n
w(iii + IIf(ii = 1, 0, n)) = _
a(i, iii + IIf(ii = 1, 0, n))
Next
dico(txt) = w
End If
Next
Next
End With
Application.ScreenUpdating = False
If Not Evaluate("isref('Alignement'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Alignement"
With Sheets("Alignement")
With .Cells(1)
.CurrentRegion.Clear
.Resize(, UBound(a, 2)).Value = Application.Index(a, 1, 0)
.Offset(1).Resize(, UBound(a, 2)).Value = Application.Index(a, 2, 0)
.Offset(2).Resize(dico.Count, UBound(a, 2)).Value = Application.Index(dico.items, 0, 0)
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Offset(1).Resize(dico.Count + 1, UBound(a, 2)).Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1)
.HorizontalAlignment = xlCenter
.Font.Size = 11
.BorderAround Weight:=xlThin
End With
With .Rows(2)
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 43
End With
.Cells(1).NumberFormat = Sheets("Base").[A1].NumberFormat
.Cells(14).NumberFormat = Sheets("Base").[N1].NumberFormat
.Columns.AutoFit
End With
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Bonjour Kiln89
merci pour le retour;
dans votre fichier je le teste comment?
bonne journée
bonjour marjolaineimsa, scraper, Doux Reveur,Curilis ,Klin89
un essai, s'ils manquent des lignes dans la partie gauche, elles seront insérées.
2 boutons pour les 2 solutions.
Re à tous,
Salut BsAlv
Marjolaine, le code un poil réajusté :
Option Explicit
Sub alignement1()
Dim a, i As Long, ii As Long, iii As Long, txt As String, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Base").Range("a1").CurrentRegion
a = .Value2
For ii = 1 To UBound(a, 2) Step 13
For i = 3 To UBound(a, 1)
txt = Join$(Array(a(i, ii + 2), a(i, ii + 3), a(i, ii + 4)), "|")
If txt <> "" Then
If Not dico.exists(txt) Then
ReDim w(1 To UBound(a, 2))
Else
w = dico(txt)
End If
For iii = 1 To 12
w(iii + IIf(ii = 1, 0, 13)) = _
a(i, iii + IIf(ii = 1, 0, 13))
Next
w(13) = a(i, 13)
dico(txt) = w
End If
Next
Next
End With
Application.ScreenUpdating = False
If Not Evaluate("isref('Alignement'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Alignement"
With Sheets("Alignement")
With .Cells(1)
.CurrentRegion.Clear
.Resize(, UBound(a, 2)).Value = Application.Index(a, 1, 0)
.Offset(1).Resize(, UBound(a, 2)).Value = Application.Index(a, 2, 0)
.Offset(2).Resize(dico.Count, UBound(a, 2)).Value = Application.Index(dico.items, 0, 0)
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Offset(1).Resize(dico.Count + 1, UBound(a, 2)).Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1)
.Font.Size = 11
.BorderAround Weight:=xlThin
.Resize(, 13).HorizontalAlignment = xlCenterAcrossSelection
.Offset(, 13).Resize(, 12).HorizontalAlignment = xlCenterAcrossSelection
End With
With .Rows(2)
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 43
With .Offset(, 13).Resize(, 12)
.Interior.ColorIndex = 44
End With
End With
.Cells(1).NumberFormat = Sheets("Base").[A1].NumberFormat
.Cells(14).NumberFormat = Sheets("Base").[N1].NumberFormat
.Columns.AutoFit
End With
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
merci à tous, vous me faites gagner un temps fou !! vous êtes top