Copier Lignes sous condition depuis autre Classeur

Le 18/09/2021 à 13:51

Bonjour à la communauté !

Je requiers une nouvelle fois de l'aide pour une fonction assez précise dans mon projet.
Je vais décrire en Français ce que je souhaite faire, pour de l'aide à le traduire en VBA ( Macro ).

FICHIER ORIGINE = "SUIVI"
FICHIER DESTINATION "RECHERCHEV"

- Sur fichier source nommé "SUIVI", Feuille nommée "PERFORMANCE"
- Copie toutes les lignes dont la colonne "C" contient la même valeur que "RECHERCHEV", Feuille "MAGASINS", Case B5

Coller toutes les lignes copiées dans Fichier RECHERCHEV, Feille STATS, à partir de la case A3.

J'espère que vous pourrez m'aider car je ne peux techniquement pas joindre les deux fichiers. Je répondra à toute demande de précision le plus rapidement possbile si nécessaire.

Merci à tous !

Le 18/09/2021 à 15:36

Bonjour Patrice83, le forum,

Un essai....

Code à placer dans un module du classeur "SUIVI".

Attention ! Les 2 classeurs doivent être ouverts !

Sub transfert()
 Dim tablo, tabloR()
 Dim k%, i%

    If Not FichOuvert("RECHERCHEV.xlsx") Then
        MsgBox "Le fichier de destination n'est pas ouvert.": Exit Sub
    End If

  tablo = ThisWorkbook.Sheets("PERFORMANCE").Range("A1").CurrentRegion
    k = 0
    For i = 1 To UBound(tablo, 1)
        If tablo(i, 3) = Workbooks("RECHERCHEV.xlsx").Sheets("MAGASINS").Range("B5") Then
            ReDim Preserve tabloR(1 To 6, 1 To k + 1) '......6 = nombre de colonnes....à adapter
            For j = 1 To 6 '.................................6 = nombre de colonnes....à adapter
                tabloR(j, 1 + k) = tablo(i, j)
            Next j
            k = 1 + k
        End If
    Next i
     Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("A3").CurrentRegion.Offset(1, 0).ClearContents
    On Error Resume Next
     Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("A3").Resize(UBound(tabloR, 2), 6) = Application.Transpose(tabloR) '......6 = nombre de colonnes....à adapter
    Erase tablo: Erase tabloR
     MsgBox "Transfert effectué"
End Sub

Function FichOuvert(F As String) As Boolean
'myDearFriend!  -  www.mdf-xlpages.com
    On Error Resume Next
    FichOuvert = Not Workbooks(F) Is Nothing
End Function

11suivi.xlsm (20.71 Ko)

9recherchev.xlsx (8.21 Ko)

Cordialement,

Le 18/09/2021 à 15:51

Merci xorsankukai !
Je vais tester de ce pas...
Quelle formidable communauté....

Le 18/09/2021 à 16:32

Je viens de tester sur mes fichiers et cela ne fonctionne pas, je pense que c'est juste un détail.
Mon fichier "SUIVI" est formaté un peu étrangement, et je pense que c'est à cause de cela que ça ne fonctionne pas.

Je souhaite extraire comme je disais dans la colonne "B" et non pas "C", pardon.... C'est bien la 'REGION' qui m'intéresse
Ce document ne m'appartenant pas, je ne peux pas le modifier, mais faire avec.... , c'est un document interne...

Merci pour toute aide...

Le 18/09/2021 à 18:26

Re,

Nouvelle tentative....

Sub transfert()
 Dim tablo, tabloR()
 Dim k%, i%, j

    If Not FichOuvert("RECHERCHEV.xlsx") Then
        MsgBox "Le fichier de destination n'est pas ouvert.": Exit Sub
    End If

  tablo = ThisWorkbook.Sheets("PERFORMANCE").Range("A1").CurrentRegion
    k = 0
    For i = 1 To UBound(tablo, 1)
      If Workbooks("RECHERCHEV.xlsx").Sheets("MAGASINS").Range("B5") = "" Then MsgBox "Selectionner une Région !": Exit Sub
        If tablo(i, 2) = Workbooks("RECHERCHEV.xlsx").Sheets("MAGASINS").Range("B5") Then
            ReDim Preserve tabloR(1 To 3, 1 To k + 1) '......3 = nombre de colonnes....à adapter
            For j = 1 To 3 '.................................3 = nombre de colonnes....à adapter
                tabloR(j, 1 + k) = tablo(i, j)
            Next j
            k = 1 + k
        End If
    Next i
     Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("A3").CurrentRegion.Offset(1, 0).ClearContents
     Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("A2") = "CODE": Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("A2").Font.Bold = True
     Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("B2") = "REGION": Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("B2").Font.Bold = True
     Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("C2") = "BOUTIQUES": Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("C2").Font.Bold = True
    On Error Resume Next
     Workbooks("RECHERCHEV.xlsx").Sheets("STATS").Range("A3").Resize(UBound(tabloR, 2), 3) = Application.Transpose(tabloR) '......3 = nombre de colonnes....à adapter
    Erase tablo: Erase tabloR
     MsgBox "Transfert effectué"
End Sub

Function FichOuvert(F As String) As Boolean
'myDearFriend!  -  www.mdf-xlpages.com
    On Error Resume Next
    FichOuvert = Not Workbooks(F) Is Nothing
End Function

11suivi.xlsm (21.63 Ko)

13recherchev.xlsx (8.49 Ko)

Cordialement,

Le 19/09/2021 à 12:25

Merci une nouvelle fois pour ton aide.
Si je peux abuser de ta gentillesse...

Je n'ai pas besoin de transférer les colonnes A et B juste faire le tri et récupérer à partir de la colonne C "Nom Boutique" et ensuite, j'ai 14 colonnes qui suivent le nom de la boutique... Et il faudrait que la macro soit sur le fichier RECHERVEV, pas sur PERFORMANCE ( fichier que je ne peux pas toucher ) ?

Est-il possible de supprimer la sélection du nom de Région sur "MAGASIN" car cette info s'écrit automatiquement dans mon fichier et ne changera jamais ?
Merci encore 10.000 fois !!!!

Le 19/09/2021 à 17:37

Bonjour,

A tester.....la macro est donc dans un module du fichier rechercheV.xlsm....

Sub transfert()
 Dim tablo, tabloR()
 Dim k%, i%, j

  Application.ScreenUpdating = False

     If Not FichOuvert("SUIVI.xlsx") Then
      MsgBox "Le fichier de destination n'est pas ouvert.": Exit Sub
     End If

  tablo = Workbooks("SUIVI.xlsx").Sheets("PERFORMANCE").Range("A1").CurrentRegion
      k = 0
     For i = 1 To UBound(tablo, 1)
      If ThisWorkbook.Sheets("MAGASINS").Range("B5") <> "" Then
        If tablo(i, 2) = ThisWorkbook.Sheets("MAGASINS").Range("B5") Then
         ReDim Preserve tabloR(3 To 17, 1 To k + 1)
          For j = 3 To 17
           tabloR(j, 1 + k) = tablo(i, j)
          Next j
      k = 1 + k
         End If
      End If
     Next i

     With ThisWorkbook.Sheets("STATS")
      .UsedRange.Borders.LineStyle = xlNone
      .UsedRange.Interior.Color = xlNone
      .Range("A2").CurrentRegion.Offset(1, 0).ClearContents
      For j = 3 To 17
       .Cells(2, j - 2) = Workbooks("SUIVI.xlsx").Sheets("PERFORMANCE").Cells(1, j)
       .Cells(2, j - 2).Font.Bold = True: .Cells(2, j - 2).Interior.Color = vbGreen
      Next j
       On Error Resume Next
       .Range("A3").Resize(UBound(tabloR, 2), 15) = Application.Transpose(tabloR)
       .Range("A2:O" & .Range("A" & Rows.Count).End(xlUp).Row).Borders.Weight = xlThin
     End With
       Erase tablo: Erase tabloR
       MsgBox "Transfert effectué"
End Sub

Function FichOuvert(F As String) As Boolean
'myDearFriend!  -  www.mdf-xlpages.com
    On Error Resume Next
    FichOuvert = Not Workbooks(F) Is Nothing
End Function

7recherchev.xlsm (20.82 Ko)

9suivi.xlsx (12.16 Ko)

Cordialement,

Le 19/09/2021 à 18:04

Vraiment merci pour ton aide, je vais tester !

Le 20/09/2021 à 10:43

Bonjour,

Je viens de tester et cela fonctionne avec le fichier exemple créé par vos soins.
Cependant, lorsque je copie et colle mes données dans le fichier exemple, j'ai une erreur avec

tabloR(j, 1 + k) = tablo(i, j)

Je pensais que cela venait du formatage des cellules, mais j'ai importé en texte brut sans mise en forme et aucun changement....

Je désespère de trouver une solution.

J'ai essayé une nouvelle approche mais j'ai du mal à adapter le code :

Sub IMPORT_STAT()

Dim x As Long
Dim y As Long
Dim c As Range
Dim rdata As Range

x = Feuil3.Range("A65536").End(xlUp).Row
y = Feuil12.Range("A3:O100").End(xlUp).Row + 1

Set rdata = Feuil3.Range("B2:B" & x)

If y >= 2 Then Feuil12.Range("A3:O100" & y).ClearContents

For Each c In rdata
  If c.Value = Feuil1.Range("B5").Value Then
    Feuil3.Range("A" & c.Row & ":D" & c.Row).Copy Destination:=Feuil12.Range("A3" & y)
  End If
  y = Feuil12.Range("A65536").End(xlUp).Row + 1
Next c

End Sub

Merci encore pour tout ce que vous faites !

Le 20/09/2021 à 11:29

Bonjour à tous !

Si VBA n'est pas un horizon indépassable et puisque vous disposez d'Excel 365, je vous livre une proposition via Power Query.

Le fichier va lire le classeur Suivi (chemin à paramétrer dans la feuille "Param PQ") et une simple actualisation (automatisable via un code VBA léger) vous retournera les éléments attendus en fonction de votre choix région (ChoixRégion).

Dans le fichier suivi, j'ai procédé à la création d'un tableau structuré (t_Performance).

16patrice83-recherche-magasins-v0.xlsx (24.19 Ko)

Le 20/09/2021 à 11:35

Hey JFL !

Merci pour votre contribution. Je regarde ça des que possible !

Le 20/09/2021 à 13:03

Bonjour Patrice83, JFL, le forum,

Difficile pour moi de t'aider sans fichier,

Tes données commencent bien en A1 ?
La dernière colonne est bien la colonne Q ?
Pas de ligne entièrement vide sous A1 ?

Cordialement,

Le 20/09/2021 à 22:02

Cher xorsankukai,

Dans mon fichier les stats doivent s'implémenter à partir de A3, alors c'est peut être ça le soucis ?

Parce que tout semble bien fonctionner, et cela pourrait être une solution....
Merci encore pour ton aide, c'est très gentil !

Le 20/09/2021 à 22:03

Cher JFL,

Je n'ai pas trouvé le fichier SUVI dans votre proposition, juste le fichier recherchemagasins..
De ce fait je ne peux pas tester votre proposition, ou alors je n'ai pas compris...

Merci encore pour votre proposition,

Le 20/09/2021 à 22:23

Bonsoir à tous ! Xorsankukai

Patrice83 a écrit :
Je n'ai pas trouvé le fichier SUVI dans votre proposition, juste le fichier recherchemagasins..
De ce fait je ne peux pas tester votre proposition, ou alors je n'ai pas compris...

Dans le classeur transmis, la cellule nommée "FichierSuivi" de la feuille "Param PQ" contient l'emplacement de VOTRE fichier SUIVI.
Vous renseignez cette cellule et vous actualisez. C'est tout.

Le 20/09/2021 à 23:06

Merci JFL,

Je vais tester ça !

Merci,

Le 21/09/2021 à 16:18

Chef JFL, j'ai passé un long moment a aborder PowerQuery et je dois avouer que j'ai jetté l'éponge. Le ficher que je vais chercher ne se combine pas avec votre proposition. Je vais essayer d'adapter la proposition précédente de xorsankukai mais j'ai un soucis avec le collage qui demeure...

Le 21/09/2021 à 16:33

Patrice83 a écrit :
Le ficher que je vais chercher ne se combine pas avec votre proposition.

Si les fichiers réels SUIVI et RECHERCHEMAGASINS ont une structure identique à celles de vos fichiers tests, il n'y a aucune raison que cela ne fonctionne pas !

Le 21/09/2021 à 17:21

Alors je vais re essayer. Quand vous parlez de structure c'est le nombre et le nom des colonnes ? Je ne peux pas toucher du tout au fichier SUIVI qui est verrouillé. Demain, j'ai 3h de TGV, je vais me mettre la dessus... promis !

merci encore !

Le 21/09/2021 à 17:45

Patrice83 a écrit :
Je ne peux pas toucher du tout au fichier SUIVI qui est verrouillé.

Ce n'est pas un souci.
Par contre il est nécessaire que vous communiquiez un fichier exemple représentatif de votre réalité. Nous bâtirons la/les requête(s) sur ce fichier.