Discussion :

[nhug1]

Bonjour à tous

Je travaille sur un petit programme dont le but est assez simple: Extraire les données correspondant au pays dans de nouveaux fichiers créés par VBA

1) Mon document principal ressemble à ça:

2) grâce à un petit bout de code, j'ai rempli les cellules vide en A:A
3) Ce remplissage me permet de réutiliser un code déjà existant que j'ai adapté:

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
 
Sub testtest2()
 
Dim tbl()
Dim montab As Variant
Dim I As Long
Dim J As Long
Dim V As Variant
 
Dim workbook_source As String
Dim nom_de_la_feuille_active As String
 
 
 'on rappelle ici le chemin du fichier source en l'attribuant à la variable "chemin"
    Chemin = ThisWorkbook.Path & "\"
    'On vient ici assigner le nom du classeur actif à une variable
    workbook_source = ActiveWorkbook.Name
    'On vient ici assigner le nom de la feuille active à une variable
    nom_de_la_feuille_active = ActiveSheet.Name
 
montab = Array("HK", "Chennai", "Mumbai", "Singapore", "Portugal", "Spain", "Brazil", "France", "Belgium", "Germany", "Hungar", "Netherlands", "Poland", "Italy", "Switzerland", "Greece", "Luxembourg", "Guernsey", "Jersey", "Ireland", "UK", "USA", "Corporate", "Colombia", "Beijing", "Japan", "Morocco", "Turkey", "Cayman")
 
With ActiveSheet
 
Set PlageDeRecherche = Range("A:A")
 
End With
 
For V = LBound(montab) To UBound(montab)
 
MsgBox ActiveWorkbook.Name
 
requete = montab(V)
MsgBox requete
 
    Set trouve = PlageDeRecherche.Find(requete, , xlValues, xlPart)
 
    'Si la valeur que l'on recherche n'est pas comprise dans la plage de recherche alors apparaît un message d'erreur
    If trouve Is Nothing Then
 
        MsgBox "'" & requete & "' n'est pas présent dans " & PlageDeRecherche.Address(0, 0)
 
    Else
        adr = trouve.Address
        Erase tbl
        'boucle pour récupérer les numéros de ligne dans le tableau
        Do
 
            I = I + 1
 
            ReDim Preserve tbl(1 To I)
 
            tbl(I) = trouve.Row
 
            Set trouve = PlageDeRecherche.FindNext(trouve)
 
        Loop While adr <> trouve.Address
 
 'On suspend le rafraichissement d'écran durant la durée du traitement pour éviter de ralentir le programme, voire de
    'le faire planter
    Application.ScreenUpdating = False
 
    With Workbook
            Application.Workbooks.Open Filename:=Chemin & requete & ".xlsx"
            nom_du_workbook = ActiveWorkbook.Name
            Workbooks(nom_du_workbook).Activate
            MsgBox nom_du_workbook
 
 
            For I = 1 To UBound(tbl)
                    'Ligne de code qui copie les données
                    Workbooks(workbook_source).Sheets(1).Rows(tbl(I)).EntireRow.Copy Destination:=Workbooks(nom_du_workbook).Sheets(1).[A1].Offset(I, 0):
 
            Next I
 
        Workbooks(nom_du_workbook).Save
        Workbooks(nom_du_workbook).Close
 
 
End With
        'On réactive le raffraichissement d'écran pour voir les changements effectués sur le document
    Application.ScreenUpdating = True
 
 
    End If
 
Next V
 
 
End Sub

Mes problèmes:

1°) Pour une raison inconnue mon programme ne fonctionne que sur les deux premiers pays contenus dans mon array (erreur 1004) sur la ligne de copie
2°) Je voudrais que les lignes copiées conservent exactement leur position dans le fichier extrait. Autrement dit si les lignes correspondant à la pologne c'est A353:A512, je veux que dans le document de destination celà soit également le cas

J'ai mis des msgbox un peu partout pour voir s'il prenait les bon workbook etc et apparemment oui donc je sèche un peu

merci messieurs et mesdames pour toute aide apportée!

PS: L'edit est dû au fait que j'ai su trouver réponse par moi-même à mes autres problèmes :-)

Bonne journée!