XL 2013 Mise a jour d'une base de donnee

[rhadamanthe]

Bonjour !

Je sollicite votre bienvaillance du VBA pour mettre un jour un tableau a partir de plusieurs tableaux tout en conservant un suivi de la mise a jour.

Veuillez trouver ci-joint un exemple : la partie delicate etant d'identifir les lignes identiques ou non et de colorier les differences. Si vous avez un autre exemple proche, n'hesitez pas a m'en faire part !

Merci d'avance de votre attention.

Bonne journee,

rhad

 

[sousou]

Re : Mise a jour d'une base de donnee

Bonjour
Voilà ce que je te propose en tous cas de quoi avancé.

Il faudra sans doute ajouter un tri pour replacer les nouvelles lignes dans l'ordre

A tester et re tester....
Avant de finaliser en fonction de ton projet exact

Principe test si même identité les quatre premières colonnes
si oui test de modifications sur les colonnes suivantes
Traitement si identique, si modifiées ou si nouvelles lignes

Une fois terminé, regarde si des ligne n'ont pas été marquées alors suppression.

A suivre sans doûte

 

[rhadamanthe]

Re : Mise a jour d'une base de donnee

Ca a l'air de fonctionner, je l'adapte a mon cas et reviens vers toi si ca bloque.

Merci beaucoup ! Bonne journee !

rhad

 

[rhadamanthe]

Re : Mise a jour d'une base de donnee

Bonjour,

J'ai helas un petit soucis que je ne comprends pas lors de la creation des nouvelles cellules, j'ai simplement diminue la zone de comparaison et agrandi la zone de selection (+change quelques noms) selon le modele suivant:

Public debphrase
Public ligneretour
Sub deb()

analyse ("UP01")
analyse ("UP02")
analyse ("UP03")
With Sheets("Actual")
Set debfich = .Range("B6")
While debfich.Offset(n, 0) <> ""
If debfich.Offset(n, -1) = "" Then
debfich.Offset(n, -1).Interior.Pattern = xlPatternNone
debfich.Offset(n, -1).Interior.ColorIndex = 5
debfich.Offset(n, -1) = "Deleted"
End If
n = n + 1
Wend
End With
End Sub

Sub analyse(feuille)
With Sheets(feuille)
n = 0
Set debfich = .Range("A6")
While debfich.Offset(n, 0) <> ""
Set debligne = .Range(debfich.Offset(n, 0), debfich.Offset(n, 1))
Set finligne = .Range(debfich.Offset(n, 2), debfich.Offset(n, 42))
r = compare(debligne, finligne)
'MsgBox r & " : " & debphrase & " : " & ligneretour'
Set maligne = .Range(debfich.Offset(n, 0), debfich.Offset(n, 42))
Call ecrit(r, ligneretour, maligne)
n = n + 1
Wend
End With
End Sub

Function compare(debligne, finligne)
debphrase = ""
finphrase = ""
compare = "New"
For Each i In debligne
debphrase = debphrase & i.Value
Next
For Each i In finligne
finphrase = "|" & finphrase & i.Value
Next
Set tableau = New Collection
With Sheets("Actual").Range("b6")
dph = ""
fph = ""
n = 0
While .Offset(n, 0) <> ""
dph = ""
For k = 0 To debligne.Count - 1
dph = dph & .Offset(n, k)
Next
If dph = debphrase Then
Set ligneretour = .Offset(n, 0)
compare = "No change"
For k = debligne.Count To debligne.Count + finligne.Count - 1

fph = "|" & fph & .Offset(n, k)
Next
If fph <> finphrase Then compare = "Modified"

End If
n = n + 1
Wend


End With
End Function

Sub ecrit(r, lg, ligne)
n = 0
Select Case r

Case Is = "Modified"
For Each i In ligne
If lg.Offset(0, n).Value <> i.Value Then lg.Offset(0, n).Interior.ColorIndex = 3 Else lg.Offset(0, n).Interior.ColorIndex = 0
lg.Offset(0, n).Value = i.Value
n = n + 1
lg.Offset(0, -1) = r
Next
Case Is = "No change"
lg.Offset(0, -1) = r
Case Is = "New"
Set dest = lg.Parent.Cells(lg.Columns(2).End(xlDown).Row + 1, 2)
For Each i In ligne
dest.Offset(0, n).Value = i.Value
n = n + 1
dest.Offset(0, -1) = r
dest.Offset(0, n).Interior.ColorIndex = 4
Next
End Select

End Sub

J'obtiens l'erreur 1004 : application/object defined error.

Une idee de ce qui peut bloquer ?

Merci d'avance.

Bonne journee !

rhad.

 

[sousou]

Re : Mise a jour d'une base de donnee

Bonjour
merci de joindre le fichier

 

[rhadamanthe]

Re : Mise a jour d'une base de donnee

Ooopps. J'ai allege l'exemple mais l'erreur est la. Voici.

 

[sousou]

Re : Mise a jour d'une base de donnee

onsoir
dans ton cas il y a des lignes vide avant le tableau remplace dans ecrit() cette ligne
le xldown sera cherché à partir de la ligne 5
Set dest = lg.Parent.Cells(lg.Parent.Cells(5, 2).End(xlDown).Row + 1, 2)