Mise à jour d'un fichier excel

**delphine1987** · 27/04/2011, 11h59

Bonjour à tous,

J’ai un fichier source 2010 STD Activities status feuille 2010
J’ai un fichier de synthèse Analyse NQC imports+NQC avec la feuille std

Le fichier source évolue tous les jours (les données changent) . L’objectif de la macro est de copier les lignes sous certaines conditions et de les insérer (dans la feuille 2010) sous une certaine forme.

Jusqu’ici ça fonctionne très bien

Mon problème est que je souhaite mettre à jour la feuille std régulièrement. Si la ligne est déjà copiée, j’aimerais que la nouvelle ligne vienne se copier dessus la précédente sur la feuille (std)
Si la ligne n’existe pas alors l’insérer.
Pour les deux fichiers j’ai une valeur commune colonne A pour la feuille STD et colonne B pour la feuille 2010 (Fichier source).

Est ce que quelqu’un à une idée car je n’y arrive plus (je suis débutante)

Merci d'avance
Delphine

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Sub ReporterV2()
 
Dim dest As Worksheet, origine As Worksheet
Dim LastLig As Long, NewLig As Long
Dim c As Range
Dim valeur As String
Set origine = Workbooks("2010 STD Activities status.xls").Sheets("2010")
valeur = InputBox("Entrée période", "Choix de la période")
If valeur <> "" Then
    Application.ScreenUpdating = False
    With origine
        .AutoFilterMode = False
        LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        With .Range("A4:X" & LastLig)
            .AutoFilter field:=17, Criteria1:=valeur
            .AutoFilter field:=24, Criteria1:=">0"
            .AutoFilter field:=9, Criteria1:="STD"
        End With
        If .Range("A4:A" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set dest = Worksheets("std")
            NewLig = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1
            For Each c In .Range("A5:A" & LastLig).SpecialCells(xlCellTypeVisible)
                If c.Offset(0, 23).Font.Color = vbBlue Then
                    dest.Cells(NewLig, 1).Value = .Cells(c.Row, 2).Value
                    dest.Cells(NewLig, 2).Value = .Cells(c.Row, 7).Value
                    dest.Cells(NewLig, 3).Value = .Cells(c.Row, 8).Value
                    dest.Cells(NewLig, 6).Value = .Cells(c.Row, 10).Value
                    dest.Cells(NewLig, 8).Value = .Cells(c.Row, 12).Value
                    dest.Cells(NewLig, 17).Value = .Cells(c.Row, 17).Value
                    dest.Cells(NewLig, 13).Value = .Cells(c.Row, 24).Value
                    dest.Cells(NewLig, 9).Value = .Cells(c.Row, 9).Value
                    dest.Cells(NewLig, 10).Value = .Cells(c.Row, 29).Value
                    dest.Cells(NewLig, 4).Value = UCase(dest.Cells(NewLig, 1).Value) & UCase(dest.Cells(NewLig, 2).Value)
                    dest.Cells(NewLig, 4).Value = Replace(Cells(NewLig, 3).Value, " ", "")
                    NewLig = NewLig + 1
                End If
            Next c
            Set dest = Nothing
            .AutoFilterMode = False
        End If
    End With
End If
End Sub

**trollinou** · 27/04/2011, 13h19

Salut ,

A adapter selon tes besoins.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Sub Test()
Dim oRange As Range
Dim oRangeFind As Range
 
    Set oRange = ActiveSheet.Range("A:A")
    Set oRangeFind = oRange.Find("25")
    If Not oRangeFind Is Nothing Then
        MsgBox "Trouvé"
        'Remplacer la ligne
    Else
        'Insérer la nouvelle ligne
    End If
 
    Set oRange = Nothing
    Set oRangeFind = Nothing
End Sub

**delphine1987** · 27/04/2011, 14h40

Merci pour ta réponse

La valeur que je souhaite chercher change. Il faut comparer si dans les deux colonnes des deux feuilles la valeur s’y trouve. Avec ton code, il faut que la valeur soit fixe non ?
Merci
Bonne journée
Delphine

**trollinou** · 27/04/2011, 15h39

Si tu veux tester une valeur changeante et en fonction d'une feuille :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
Public Sub AppelTest
Dim oSheetSource as WorkSheet
Dim oSheetDest as WorkSheet
 
     If Test(oSheetDest, "25") Is Nothing Then
         'Ajout de la nouvelle ligne 
     Else
         'Remplacement de la ligne
     End If
 
End Sub
 
Private Function Test(oSheet as Worksheet, pValue as string) as Range
Dim oRange As Range
 
    Set oRange = oSheet.Range("A:A")
 
    ' Dans la procédure appelante tu testes ta fonction par Is Nothing
    ' et en fonction tu fais les opérations nécessaires
 
    Set Test = oRange.Find(pValue)
    Set oRange = Nothing
End Sub

Code plus complet:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Public Sub AddOrReplaceRow()
Dim oSheetSource As Worksheet
Dim oSheetDest As Worksheet
Dim oRange As Range
Dim lRow As Integer
 
    Set oSheetSource = ActiveWorkbook.Worksheets(1)
    Set oSheetDest = ActiveWorkbook.Worksheets(2)
 
    'Tu veux tester les lignes du fichier source
    'Tu peux évidemment pointer sur un autre classeur
 
    For lRow = 1 To oSheetSource.UsedRange.Rows.Count
        Set oRange = GetRangeGoal(oSheetDest, oSheetSource.Cells(lRow, 1))
        If oRange Is Nothing Then
            AddRow oSheetDest, oSheetSource.Cells(lRow, 1)
        Else
            ReplaceRow oSheetSource.Cells(lRow, 1), oRange
        End If
    Next lRow
 
End Sub
 
Private Function GetRangeGoal(pSheet As Worksheet, pValue As String) As Range
Dim oRange As Range
 
    ' Tu peux changer l'adresse à laquelle tu veux faire ta recherche
    Set oRange = pSheet.Range("A:A")
    Set GetRangeGoal = oRange.Find(What:=pValue, LookAt:=xlWhole, MatchCase:=True)
    Set oRange = Nothing
 
End Function
 
Private Sub AddRow(ByRef pSheet As Worksheet, ByRef pRange As Range)
Dim oRange As Range
 
    'Détermine la première ligne libre
    Set oRange = pSheet.Cells(pSheet.UsedRange.Rows.Count, 1).Offset(1, 0)
    pRange.Copy oRange
    Set oRange = Nothing
End Sub
 
Private Sub ReplaceRow(ByRef pRangeSource As Range, ByRef pRangeDest As Range)
    'Annule et remplace
    pRangeSource.Copy pRangeDest
End Sub

**delphine1987** · 28/04/2011, 11h34

Bonjour
Merci pour ta réponse

Débutant sur VBA, j’ai essayé d’intégrer la function dans le programme mais je ne parviens pas à le faire. J’ai lu le tutoriel « fonctions », j’ai compris la logique mais je n’arrive pas à l’appliquer.
Merci pour tes conseils
Bonne journée
Delphine

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Sub ReporterV2()
 
Dim dest As Worksheet, origine As Worksheet
Dim LastLig As Long, NewLig As Long
Dim c As Range
Dim valeur As String
Dim vérification As Variant
 
Set origine = Workbooks("2010 STD Activities status.xls").Sheets("2010")
valeur = InputBox("Entrée période", "Choix de la période")
If valeur <> "" Then
    Application.ScreenUpdating = False
    With origine
        .AutoFilterMode = False
        LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        With .Range("A4:X" & LastLig)
            .AutoFilter field:=17, Criteria1:=valeur
            .AutoFilter field:=24, Criteria1:=">0"
            .AutoFilter field:=9, Criteria1:="STD"
        End With
     vérification = Getrangegoal("A:A",,)
        If .Range("A4:A" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set dest = Worksheets("std")
            NewLig = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1
            For Each c In .Range("A5:A" & LastLig).SpecialCells(xlCellTypeVisible)
                If c.Offset(0, 23).Font.Color = vbBlue Then
                    dest.Cells(NewLig, 1).Value = .Cells(c.Row, 2).Value
                    dest.Cells(NewLig, 2).Value = .Cells(c.Row, 7).Value
                    dest.Cells(NewLig, 3).Value = .Cells(c.Row, 8).Value
                    dest.Cells(NewLig, 6).Value = .Cells(c.Row, 10).Value
                    dest.Cells(NewLig, 8).Value = .Cells(c.Row, 12).Value
                    dest.Cells(NewLig, 17).Value = .Cells(c.Row, 17).Value
                    dest.Cells(NewLig, 13).Value = .Cells(c.Row, 24).Value
                    dest.Cells(NewLig, 9).Value = .Cells(c.Row, 9).Value
                    dest.Cells(NewLig, 10).Value = .Cells(c.Row, 29).Value
                    dest.Cells(NewLig, 4).Value = UCase(dest.Cells(NewLig, 1).Value) & UCase(dest.Cells(NewLig, 2).Value)
                    dest.Cells(NewLig, 4).Value = Replace(Cells(NewLig, 3).Value, " ", "")
                    NewLig = NewLig + 1
                End If
            Next c
            Set dest = Nothing
            .AutoFilterMode = False
        End If
    End With
End If
End Sub

**trollinou** · 28/04/2011, 11h50

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

vérification = Getrangegoal("A:A",,)

Devrait être

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
 
'Déclaration obligatoire de l'objet avant de s'en servir
Set dest = Worksheets("std")
 
'Cette fonction renvoie un objet Range donc un set est également obligatoire
'Si le Range Is Nothing alors c'est que rien n'a été trouvé
Set vérification = Getrangegoal(dest , "A:A")

Conseil : Essaie de factoriser ton code et de mettre du commentaire pour expliquer ce que tu fais et pourquoi

**delphine1987** · 09/05/2011, 21h24

Bonsoir,
Merci pour cette réponse, je n'arrive pas à insérer ce code dans le mien, je ne sais plus comment faire.

Merci d'avance pour vos réponses
Delphine

**trollinou** · 10/05/2011, 17h35

Re,

Je récapitule ce que j'ai compris de ton code.
Dis moi si je suis à coté de la plaque :

1- Tu demandes la saisie d'une valeur ; la période
2- Tu cherches dans la feuille source via un filtre si cette valeur existe mais avec 2 critères supplémentaires
3- Si la valeur est trouvée dans la feuille de destination, tu copies les valeurs dans une nouvelle ligne

Questions :
- la valeur saisie est ponctuelle ou tu dois faire des "mises à jour" de masse ?
- Dans la feuille de destination, où faut-il chercher la valeur ?
- Dans la feuille de destination, y a t il d'autres critères ?
- Si la valeur trouvée dans la feuille d'origine est également trouvée dans la feuille de destination : annule et remplace ?

**delphine1987** · 10/05/2011, 18h33

Bonjour,

Tu as très bien compris le code, les lignes sont copiées si elles remplissent certaines conditions et selon une mise en page particulière

Réponse à ta dernière question: les données dans le fichier source sont mises à jour quotidiennement et j'aimerais que quand je veux mettre ma fauille STD à jour, les données qui ont été copiées la veille ne se recopient pas( par exemple). Donc je rentre obligatoirement ma valeur au préalable si les données ont déjà été importées elles ne sont pas recopiées sinon oui. c'est donc ce que tu me dis dans ta dernière question, la ligne est alors annulé et remplacé (car celle ci peut être mise à jour entre temps).

Chaque ligne à un numéro unique (présente dans les deux fichiers). Dans le fichier source colonne B et dans le fichier de destination colonne A.

Pour la première question, je pense que c'est de masse. Je veux dire que c'est quelque chose que je peux faire plusieurs fois par mois car les données sont mises à jour régulièrement dans le fichier source

Je peux t'envoyer un exemple de Fichier en MP comme tu veux

Encore merci pour ton aide

Delphine

**trollinou** · 11/05/2011, 12h42

Re

Oui je veux bien que tu me donnes un exemple.

Dans ton code tu ne vérifies pas l'existence de la valeur saisie.
Donc tu copies à tous les coups.

Il faut que je sache où se trouve les valeurs que tu souhaites tester

**delphine1987** · 11/05/2011, 15h42

Re
Merci pour ton aide
En PJ mes deux fichiers

La valeur cherchée est dnas la colonne Q du fichier 2010 activities status..

encore merci

**trollinou** · 11/05/2011, 17h19

Re,

essaie ça.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
Private Function GetRangeGoal(pSheet As Worksheet, pValue As String) As Range
Dim oRange As Range
 
    ' Désactive tous les filtres éventuels
    pSheet.ShowAllData
 
    Set oRange = pSheet.UsedRange
    ' Recherche la valeur
    Set GetRangeGoal = oRange.Find(What:=pValue, LookAt:=xlWhole, MatchCase:=True)
 
    ' Si la valeur est trouvée, renvoi de la ligne complète pour avoir l'ensemble des données
    If Not GetRangeGoal Is Nothing Then
        Set GetRangeGoal = GetRangeGoal.EntireRow
    End If
 
    Set oRange = Nothing
 
End Function
 
Private Function SearchRowInOrigine(ByVal pCriteria As String) As Range
Dim oSheetOrigine As Worksheet
Dim oRangeOrigine As Range
Dim lRow As Integer
 
    ' Récupération de la feuille d'origine sur laquelle on recherche la valeur
    Set oSheetOrigine = ActiveWorkbook.Worksheets("2010")
    Set oRangeOrigine = GetRangeGoal(oSheetOrigine, pCriteria)
 
    ' Recherche la ligne correspondante au critère passé en paramètre
    ' Si la ligne est trouvée, renvoi de la ligne complète
    If Not oRangeOrigine Is Nothing Then
        ' Complétion des critères
        If oSheetOrigine.Cells(oRangeOrigine.Row, 9) = "STD" And _
           oSheetOrigine.Cells(oRangeOrigine.Row, 17) = pCriteria And _
           oSheetOrigine.Cells(oRangeOrigine.Row, 24) > "0" Then
            ' Renvoi de la ligne complète
            Set SearchRowInOrigine = oSheetOrigine.Cells(oRangeOrigine.Row, 1).EntireRow
        End If
    End If
 
    Set oRangeOrigine = Nothing
    Set oSheetOrigine = Nothing
 
End Function
 
Private Function SearchRowInDestination(ByVal pCriteria As String) As Range
Dim oSheetDestination As Worksheet
Dim oRangeDestination As Range
Dim lRow As Integer
 
    Set oSheetDestination = ActiveWorkbook.Worksheets("std")
    Set oRangeDestination = GetRangeGoal(oSheetDestination, pCriteria)
 
    ' Recherche la ligne correspondante au critère passé en paramètre
    ' Si la ligne est trouvée, renvoi de la ligne complète
    If Not oRangeDestination Is Nothing Then
        If oSheetDestination.Cells(oRangeDestination.Row, 9) = "STD" And _
           oSheetDestination.Cells(oRangeDestination.Row, 17) = pCriteria Then
            ' Renvoi de la ligne complète
            Set SearchRowInDestination = oSheetDestination.Cells(oRangeDestination.Row, 1).EntireRow
        End If
    End If
 
    Set oRangeDestination = Nothing
    Set oSheetDestination = Nothing
 
End Function
 
Public Sub Test()
Dim oSheetDestination As Worksheet
Dim oRange1 As Range
Dim oRange2 As Range
Dim lRowIndex As Integer
Dim Valeutr As Variant
 
    valeur = InputBox("Entrée période", "Choix de la période")
    If valeur = "" Then Exit Sub
 
    Set oRange1 = SearchRowInOrigine("P03/10")
 
    If Not oRange1 Is Nothing Then
        Set oSheetDestination = ActiveWorkbook.Worksheets("std")
        Set oRange2 = SearchRowInDestination("P03/10")
 
        If Not oRange2 Is Nothing Then
            'Index de la ligne a remplacer
            lRowIndex = oRange2.Row
        Else
            'Index de la nouvele ligne
            lRowIndex = oSheetDestination.Range(oSheetDestination.Range("A65000").Address).End(xlUp).Row + 1
        End If
 
        With oSheetDestination
            .Cells(lRowIndex, 1).Value = oRange1.Cells(1, 2).Value
            .Cells(lRowIndex, 2).Value = oRange1.Cells(1, 7).Value
            .Cells(lRowIndex, 3).Value = oRange1.Cells(1, 8).Value
            .Cells(lRowIndex, 6).Value = oRange1.Cells(1, 10).Value
            .Cells(lRowIndex, 8).Value = oRange1.Cells(1, 12).Value
            .Cells(lRowIndex, 17).Value = oRange1.Cells(1, 17).Value
            .Cells(lRowIndex, 13).Value = oRange1.Cells(1, 24).Value
            .Cells(lRowIndex, 9).Value = oRange1.Cells(1, 9).Value
            .Cells(lRowIndex, 10).Value = oRange1.Cells(1, 29).Value
 
            ' Je ne comprends pas bien pourquoi tu fais ça
            .Cells(lRowIndex, 4).Value = UCase(.Cells(lRowIndex, 1).Value) & UCase(.Cells(lRowIndex, 2).Value)
            .Cells(lRowIndex, 4).Value = Replace(Cells(lRowIndex, 3).Value, " ", "")
        End With
 
        Set oSheetDestination = Nothing
    End If
 
 
    Set oRange1 = Nothing
    Set oRange2 = Nothing
 
End Sub

**delphine1987** · 11/05/2011, 18h41

ouuaaa merci!

Le code ne fonctionne pas le problème est :

Désactive tous les filtres éventuels

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

pSheet.ShowAllData

mais je comprends pas pourquoi et il est rien indiqué
Merci
Delphine

**trollinou** · 11/05/2011, 21h54

Met la ligne en commentaire et vois ce qui se passe

**delphine1987** · 12/05/2011, 10h53

re,

ça ne fonctionne pas
rien ne se passe..

**trollinou** · 12/05/2011, 12h39

Met moi ton fichier avec le code a dispo et je regarderai

**delphine1987** · 12/05/2011, 14h47

voilà le fichier

**trollinou** · 12/05/2011, 16h41

J'ai fait un test et cela fonctionne.
J'ai mis en valeur "P01/11"

J'ai repris les critères que tu avais mis en place, à savoir le STD et > 0

Est-ce que tu peux m'expliquer l'attendu en terme de fonctionnement et de rendu ?

Edit :
Je n'ai travaillé que sur le classeur "Analyse ...."
Si la feuille source se trouve sur l'autre classeur il faut changer l'affectation

**delphine1987** · 12/05/2011, 18h07

Je comprends pas sur mon Pc ça ne fonctionne pas. Est ce que ma version 2000 peut expliquer ça?
Encore merci
Delphine

**trollinou** · 13/05/2011, 10h28

Si tu sais faire le déboguage pas à pas, fais le et vérifie ce que le programme fait.

Je travaille en 2003 donc il est possible qu'il y ait un problème de compatibilité.

Ajoute également une gestion d'erreur cela te permettra de savoir dans quelle partie du code cela ne fonctionne pas

Mise à jour d'un fichier excel

Macros et VBA Excel

Discussions similaires

Partager

Partager