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

Mise à jour d'un fichier excel

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager