[XL-2003] Macro tri répartition

[korni184]

Bonjour,

Actuellement je repartie les données dans trois sheets différentes, suivant le pays qui se trouvent en colonne C.

Vu que les données sont mises à jour plusieurs fois dans la journée, je voudrais que les données qui se trouvent dans ma sheet de répartition ("Fiche de Travail J") (nommée ainsi) remplace automatiquement les données déjà existante dans les sheets suivantes.

Actuellement, ils ajoutent les données à la suite.

Est-ce que cela est possible ? Par contre si imaginons je n'ai pas de données pour le pays MAROC (exemple) qu'il laisse automatiquement les données deja présente dans les sheets.

Et dans un deuxième temps, est-ce que je peux ajouter un petit message d'erreur, disant que si il y pas de données, il y a pas de tri !

Merci d'avance

Bàv

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Dim i As Long 
Dim iCible As Long 
Dim shSource As Worksheet 
Dim Sh As Worksheet 
 
Set shSource = Sheets("Fiche de Travail J") 
 
'Copie les données dans les feuilles Pays 
    For i = 1 To shSource.Range("A" & Rows.Count).End(xlUp).Row 
    Set Sh = Sheets(Range("C" & i).Value) 
    iCible = Sh.Range("A" & Rows.Count).End(xlUp).Row + 1 
    If iCible = 2 And Sh.Range("a1").Value = "" Then iCible = 1 
    shSource.Rows(i).Copy Sh.Range("A" & iCible) 
    'Vide la ligne Copiée 
    shSource.Rows(i).ClearContents
Next i

[mercatog]

Un exemple en utilisant un filtre automatique

Code :

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 Dispatch()
Dim LastLig As Long, i As Long
Dim Sh As Worksheet
Dim Dico As Object
 
Application.ScreenUpdating = False
Set Dico = CreateObject("scripting.dictionary")
With Worksheets("Fiche de Travail J")
    .AutoFilterMode = False
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Création d'un dictionnaire sur les données de la colonne C
    For i = 2 To LastLig
        If Not Dico.exists(.Range("C" & i).Value) Then Dico.Add .Range("C" & i).Value, ""
    Next i
    'Filtrage automatique et copie
    For i = 0 To Dico.Count - 1
        .Range("A1:C" & LastLig).AutoFilter Field:=3, Criteria1:=Dico.Keys(i)
        If Existe(Dico.Keys(i)) Then
            Set Sh = ThisWorkbook.Worksheets(Dico.Keys(i))
            Sh.UsedRange.Clear
        Else
            Set Sh = Worksheets.Add(After:=Sheets(Sheets.Count))
            Sh.Name = Dico.Keys(i)
        End If
        .Range("A1:A" & LastLig).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sh.Range("A1")
    Next i
 
    .AutoFilterMode = False
End With
Set Sh = Nothing
Set Dico = Nothing
End Sub
 
Function Existe(ByVal ShName As String) As Boolean
Dim Sh As Worksheet
 
For Each Sh In ThisWorkbook.Sheets
    If Sh.Name = ShName Then
        Existe = True
        Exit For
    End If
Next Sh
End Function