transfere données "disposition source" et "dispositions destination" différentes

Question

Bonjour, je suis nul en VBA. Malgré cela je voudrai donner un coup de main à un bon ami (aussi nul que moi en programmation) qui n’a pas beaucoup de temps par rapport à moi. Après beaucoup de recherches, j’ai trouvé 2 codes adaptés pour nos besoins mais qui ne donnent pas parfaitement le résultat escompté. Sub Module_6() Dim bd As Object 'déclare la variable bd (onglet BD) Dim dico As Object 'déclare la variable dico (DICtiOnnaire) Dim dl As Integer 'déclare la variable dl (Dernière Ligne) Dim pl As Range 'déclare la variable pl (PLage) Dim cel As Range 'déclare la variable cel (CELlule) Dim temp As Variant 'déclare la variable temp (tableau TEMPoraire) Dim i As Integer 'déclare la variable i (Incrément) Dim dics As Object 'déclare la variable dics (DICtionnaireS) Dim o As Object 'déclare la variable o (Onglet) Dim dest As Range 'déclare la variable dest (cellule de DESTination) Dim teo As Variant 'déclare le tableau de variables teo (tableau TEmporaire Outils) Dim x As Integer 'déclare la variable x Dim y As Integer 'déclare la variable y Set bd = Sheets("Consultation") 'définit l'onglet bd Set dico = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico dl = bd.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet bd Set pl = bd.Range("B8:B" & dl) 'définit la plage pl For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl dico(cel.Value) = "" 'alimente le dictionnaire dico Next cel 'prochaine cellule de la boucle temp = dico.keys 'récupère le dictionnaire sans doublon dans le tableau temp For i = 0 To UBound(temp) 'boucle 1 : sur toutes les valeurs uniques du tableau temp Set o = Sheets(temp(i)) 'définit l'onglet o o.Range("D6:X6").Clear o.Range("A6:A100").Clear 'o.UsedRange.Clear 'efface les anciennes données bd.Range("A1").AutoFilter 'lance le filtre automatique bd.Range("A1").AutoFilter field:=2, Criteria1:=temp(i) 'filtre automatique sur la colonne 2 (=B) avec la valeur temp(i) comme critère Set dics = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dics For Each cel In pl.Offset(0, 1).SpecialCells(xlCellTypeVisible) 'boucle 2 : sur toutes les cellules visibles cel de la plage pl déclalée d'un colonne à droite dics(cel.Value) = "" 'alimente le dictionnaire dics Next cel 'prochaine cellule de la boucle 2 teo = dics.keys 'définit le tabeau teo y = 2 'initialise la variable y For x = 0 To UBound(teo) 'boucle 3 : sur toutes les outils (sans doublon) o.Cells(6, y + 2).Value = teo(x) 'place l'outil dans le tableau o.Cells(6, y + 2).HorizontalAlignment = xlCenter o.Cells(6, y + 2).VerticalAlignment = xlCenter o.Cells(6, y + 2).Font.Bold = True o.Cells(7, y + 2).Value = "Potentiel" & Chr(10) & "(mV)" o.Cells(7, y + 2).HorizontalAlignment = xlCenter o.Cells(7, y + 2).VerticalAlignment = xlCenter o.Cells(7, y + 2).Font.Bold = True y = y + 2 'incrément y o.Cells(6, y + 1).Value = teo(x) 'place l'outil dans le tableau o.Cells(6, y + 1).HorizontalAlignment = xlCenter o.Cells(6, y + 1).VerticalAlignment = xlCenter o.Cells(6, y + 1).Font.Bold = True o.Cells(7, y + 1).Value = "Courant" & Chr(10) & "(mA)" o.Cells(7, y + 1).HorizontalAlignment = xlCenter o.Cells(7, y + 1).VerticalAlignment = xlCenter o.Cells(7, y + 1).Font.Bold = True o.Cells(7, y + 2).Value = "Direction" o.Cells(7, y + 2).HorizontalAlignment = xlCenter o.Cells(7, y + 2).VerticalAlignment = xlCenter o.Cells(7, y + 2).Font.Bold = True o.Cells(7, y + 2).Offset(-1, 0).Value = "Direction" o.Cells(7, y + 2).Offset(-1, 0).HorizontalAlignment = xlCenter o.Cells(7, y + 2).Offset(-1, 0).VerticalAlignment = xlCenter o.Cells(7, y + 2).Offset(-1, 0).Font.Bold = True o.Cells(7, y + 3).Value = "Observations" o.Cells(7, y + 3).HorizontalAlignment = xlCenter o.Cells(7, y + 3).VerticalAlignment = xlCenter o.Cells(7, y + 3).Font.Bold = True o.Cells(7, y + 3).Offset(-1, 0).Value = "Observations" o.Cells(7, y + 3).Offset(-1, 0).HorizontalAlignment = xlCenter o.Cells(7, y + 3).Offset(-1, 0).VerticalAlignment = xlCenter o.Cells(7, y + 3).Offset(-1, 0).Font.Bold = True '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '.Range("C" & ou).HorizontalAlignment = xlCenter ' .Range("C" & ou).VerticalAlignment = xlCenter ' .Range("C" & ou).Font.Bold = False ' .Columns("C:C").ColumnWidth = 7 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' y = y 'incrément y Next x 'prochain outil de la boucle 3 'For Each cel In pl.Offset(0, 2).SpecialCells(xlCellTypeVisible) 'boucle 4 : sur toutes les cellules visibles cel de la plage pl déclalée de deux colonnes à droite ' Set dest IIf(o.Range("A8").Value "", o.Range("A8"), o.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)) 'définit la cellule de destination ' dest.Value = cel.Value 'récupère dans dest la valeur de la cellule cel 'Next cel 'prochaine cellule de la boucle 4 bd.Range("A1").AutoFilter 'annule le filtre automatique Next i 'prochaine valeur de la boucle 1 End Sub Option Explicit Public Sub traitement() Dim c As Range, derlig As Long, i As Long, ou As Long, enA As String, taborig Dim dercol As Integer derlig = Worksheets("Consultation").Range("B" & Rows.Count).End(xlUp).Row If derlig < 8 Then MsgBox "pas de données à traiter !": Exit Sub taborig = Worksheets("Consultation").Range("A8:M" & derlig) For Each c In Worksheets("Parametre").Range("A:A").SpecialCells(xlCellTypeConstants) If c.Text <> "" Then With Worksheets(c.Value) .Range(.Cells(8, 1), .Cells(Rows.Count, Columns.Count)).ClearContents ' on vide chaque feuille après ligne 7 End With End If Next For i = 1 To UBound(taborig) With Worksheets(taborig(i, 2)) ou = ou_ecrire(Worksheets(taborig(i, 2))) enA = taborig(i, 4) & Chr(10) & taborig(i, 5) & Chr(10) & taborig(i, 12) enA = Replace(enA, Chr(10) & Chr(10), Chr(10)) .Range("A" & ou).Value = enA .Range("A" & ou).HorizontalAlignment = xlCenter .Range("A" & ou).VerticalAlignment = xlCenter .Range("A" & ou).Font.Bold = True .Columns("A:A").ColumnWidth = 18.71 .Range("B" & ou).Value = taborig(i, 6) .Range("B" & ou).HorizontalAlignment = xlCenter .Range("B" & ou).VerticalAlignment = xlCenter .Range("B" & ou).Font.Bold = False .Columns("B:B").ColumnWidth = 7 .Range("C" & ou).Value = taborig(i, 7) .Range("C" & ou).HorizontalAlignment = xlCenter .Range("C" & ou).VerticalAlignment = xlCenter .Range("C" & ou).Font.Bold = False .Columns("C:C").ColumnWidth = 7 .Range("A6").Value = "Localisation" & Chr(10) & "Poste" .Range("A6").Name = "Calibri" .Range("A6").Font.Size = 11 .Range("A6").HorizontalAlignment = xlCenter .Range("A6").VerticalAlignment = xlCenter .Range("A6").Font.Bold = True .Range("A7").Value = "Localisation" & Chr(10) & "Poste" .Range("A7").Name = "Calibri" .Range("A7").Font.Size = 11 .Range("A7").HorizontalAlignment = xlCenter .Range("A7").VerticalAlignment = xlCenter .Range("A7").Font.Bold = True .Range("B6").Value = "Redresseur" .Range("B6").Name = "Calibri" .Range("B6").Font.Size = 11 .Range("B6").HorizontalAlignment = xlCenter .Range("B6").VerticalAlignment = xlCenter .Range("B6").Font.Bold = True .Range("B7").Value = "Tension" & Chr(10) & "(V)" .Range("B7").Name = "Calibri" .Range("B7").Font.Size = 11 .Range("B7").HorizontalAlignment = xlCenter .Range("B7").VerticalAlignment = xlCenter .Range("B7").Font.Bold = True .Range("C6").Value = "Redresseur" .Range("C6").Name = "Calibri" .Range("C6").Font.Size = 11 .Range("C6").HorizontalAlignment = xlCenter .Range("C6").VerticalAlignment = xlCenter .Range("C6").Font.Bold = True .Range("C7").Value = "Courant" & Chr(10) & "(A)" .Range("C7").Name = "Calibri" .Range("C7").Font.Size = 11 .Range("C7").HorizontalAlignment = xlCenter .Range("C7").VerticalAlignment = xlCenter .Range("C7").Font.Bold = True dercol = .Range("A6").End(xlToRight).Column + 1 '.Cells(6, dercol).Value = "Observations" '.Cells(7, dercol).Value = "Observations" 'MsgBox taborig(i, 2) End With Next End Sub Private Function ou_ecrire(f As Worksheet) As Long ou_ecrire = f.Range("A" & Rows.Count).End(xlUp).Row + 1 If ou_ecrire <8 Then ou_ecrire 8 End Function Je précise que ces 2 codes ne sont pas de moi, ce sont des codes que j'ai trouvé sur des forums et que j'ai adapté mais ne répondent pas exactement à mes besoins. à chaque cas sa solution. Donc l’objectif est de transférer des données de la feuille nommée "Consultation" vers 3 feuilles à imprimer mais dont la disposition change. Ça va être un peu long et j’espère que je serai clair dans mes explications. Présentation de la feuille "Consultation" contenant les données à transférer : A1 :M6 = = > entête de la feuille A7 :M7 = = > entête du tableau A8 :M&dernière ligne = = >plage de données (tableau) À partir de la ligne 8 jusqu’à la dernière ligne (nombre de lignes variables) A8 :Aderligne= = >N° B8 :Bderligne = = > contient Olc, Gzc, Stt, Tiers (actuellement, représentent aussi les noms des feuilles où seront transférer les données. Il ne doit rester que les feuilles Olc, Gzc et Stt) C8 :Cderligne = = > ouvrage (ces données seront reportées sur les autres feuilles en ligne à partir de la cellule D4 (colonne transposée), chaque donnée sera écrite 2 fois car pour chacune d’elles correspond 2 données (potentiel et courant)). On voudrait cette disposition que pour les feuilles Olc et Gzc. NB : ce résultat est obtenu en exécutant les 2 codes. D8 :Dderligne = = > n° poste qui sera concaténé avec colonne’ E’ et colonne’L’ sur les feuille Olc, Gzc et Stt en colonne A E8 :Ederligne = = >loc poste idem que col D F8 :Fderligne = = >tension (reporter avec code traitement et fonction ou_ecrire) G8 :Gderligne = = >idem que ci-dessus H8 :Hderligne = = >cette colonne ne sera pas transférée I8 :Iderligne = = >potentiel , ces données seront transférées en feuilles Olc et Gzc (suggestion : peut-être utiliser fonctions index equiv , étant donné que la disposition a changé) J8 :Jderligne = = >idem que ci-dessus K8 :Kderligne = = >Direction, données à transférer en feuilles Olc et Gzc dans colonne dont l’entête est ‘Direction’ L8 :Mderligne = = >concaténer avec données colonne ‘D’ sur les feuilles Olc, Gzc et Stt M8 :Mderligne = = > idem que pour K8 :Kderligne Feuille Olc et Gzc : en exécutant les 2 codes on obtient le résultat escompté, il manque le transfèrt des données correspondantes aux colonnes I,J ,K et M Feuille Stt : avec le code "traitement" et la fonction "ou_ecrire", on obtient le bon transfert mais il manque la colonne "observation" dans laquelle il faut concaténer les données correspondantes à "Tiers" de la feuille "Consultation" colonne B. On repère sur les feuilles Olc, Gzc et Stt les données de La feuille "Consultation"[col D & chr(10) & col E & chr(10)& col L & col K] , pour atteindre la cellule (feuilles Olc, Gzc et Stt) à l’intersection de [col A & col K]. il faudrait peut-être mettre ces concaténation dans une colonne et effacer toutes les données à la fin de la procédure. Ceci est juste une idée car j’ai un code qui me supprime les lignes en doublons, sur le principe de concaténation de toutes les cellules de chaque ligne. Je ne sais pas si j’ai été clair et vous en suis gré par avance. Je peux mettre à disposition le fichier. Ps : avec les 2 codes les quatre feuilles doivent exister sinon bug : "erreur d’execution 9. L’indice n’appartient pas à la sélection." Je récapitule, je ne voudrai avoir que 3 feuilles (Olc, Gzc et Stt)

ucfoutu · Answer

Bonjour,
Je me refuse personnellement à tenter de corriger un tel code, qui n'est pas de toi, a été "récupéré" et n'est pas adapté à tes besoins.
En parlant de ces besoins, ils me semblent être très similaires à ceux que j'ai traités dans la discussion :
Tapez le texte de l'url ici.
Que je te conseille donc de lire de bout en bout, d'analyser, de comprendre et d'adapter. 

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviendrai que si nécessité de la compléter.

Blek1 · Answer

Bonjour, j'avais espéré trouver une aide sur ce forum d'autant plus que l'un des codes que j'ai adapté est de vous (en réponse à scribetout). J'ai tout lu de bout en bout, analysé, je n'ai pas tout compris mais j'ai tenté d'adapter.Dans notre cas les données de la colonne B (de la feuille source) sont de 4 et ne changeront jamais.On ne cherche pas créer les feuilles, elles le sont déjà au nombre de 3, par contre on efface les anciennes données. Je suis nul en VBA et voudrais aider un ami. J'espérais en m'inscrivant à ce forum trouver assez rapidement une réponse. On ne peut pas être "érudit" dans tous les domaines. Tout en respectant votre décision, j'en prends acte et ne baisse pas les bras pour autant, je poursuis mes recherches sur la toile jusqu'à satisfaction.
Merci et bonne continuation!

ucfoutu · Answer

1) Tu as eu ma réponse
2) Le code que j'ai donné dans la discussion de référence n'utilise pas de Dictionnaire !
3) si par :
J'espérais en m'inscrivant à ce forum trouver assez rapidement une réponse.
tu attendais un code tout fait, à recopier, tu t'es trompé.
J'insiste : dans le code de référence, tu as tout pour résoudre ton problème.
Rien ne t'oblige à créer des feuilles (si tu ne veux pas de cette partie, il te suffit de la sauter !)
Reviens avec un code tenté sur ces bases (montre donc que tu en comprends au moins l'essence) et je t'aiderai, mais uniquement à cette condition-là. 

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviendrai que si nécessité de la compléter.

Blek1 · Answer

Rebonjour,
Je ne m'attendais pas à un code tout fait, je suis pas dans un freeshop.
je suis débutant et ne maîtrise pas les subtilités du codage.
je vous remercie de m'avoir éclairé  pour la partie création des feuilles.
Vous me dites aussi que dans le code j'ai tout pour résoudre mon problème.
Est-ce que dans ce code il y a la possibilité de transférer le données en transposition (comme dans excel: faire copier et collage spécial transposer)?

Pour trouver une solution en utilisant les fonctions d'Excel, j'en suis capable (soit avec Index/Equiv ou Sommeprod). J'ai déjà utilisé l'enregistreur de macros pour avoir la traduction de la formule pour VBA (Anglais). Mais je suis incapable de coder en VBA, surtout que des données qui étaient disposées en colonne sont transférées en ligne, et de surplus le nombre de ces données est variable.

Je vous remercie quand même pour votre intervention.

Blek1 · Answer

Bonjour,

J'ai pas mal consulté, et j'ai compris qu'on ne pose qu'une seule question à la fois. Bien.

J'ai revenu mon code, de la feuille source (A8:M & derlig), je suis parvenu à transférer ces données pour constituer des tableaux à 2 entrées (ligne/colonne). Dans un premier temps, je voudrais transférer les données de 2 colonnes (F et G) en utilisant l'objet dictionary (que je ne maîtrise pas bien).
Il me manque un additem ou addkey, je ne sais pas trop mais mon code n'est pas complet. Pour le reste, c'est comme il vous conviendra. Soit on continue avec une autre question soit j'ouvre une autre discussion.

Je vous remercie d'avance.

Voici donc mon code
Sub essai2()
Dim bd As Object '(onglet BD)
Dim dico As Object '(DICtiOnnaire)
Dim dl As Integer '(Dernière Ligne)
Dim pl As Range 'PLage)
Dim cel As Range '(CELlule)
Dim temp As Variant '(tableau TEMPoraire)
Dim i As Integer '(Incrément)
Dim dics As Object 'DICtionnaireS)
Dim o As Object '(Onglet)
Dim teo As Variant '(tableau TEmporaire Outils)
Dim x As Integer 'variable x
Dim y As Integer 'variable y
Dim dercol As Integer '(Dernière colonne)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set bd = Sheets("Consultation") 'définit l'onglet bd
Set dico = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico
dl = bd.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet bd
Set pl = bd.Range("B8:B" & dl) 'définit la plage pl
For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl
    dico(cel.Value) = "" 'alimente le dictionnaire dico
Next cel 'prochaine cellule de la boucle
temp = dico.keys 'récupère le dictionnaire sans doublon dans le tableau temp

For i = 0 To UBound(temp) 'boucle 1 : sur toutes les valeurs uniques du tableau temp
    Set o = Sheets(temp(i)) 'définit l'onglet o
    o.UsedRange.Clear 'efface les anciennes données
    o.UsedRange.MergeCells = False
    
    bd.Range("A1").AutoFilter 'lance le filtre automatique
    bd.Range("A1").AutoFilter field:=2, Criteria1:=temp(i) 'filtre automatique sur la colonne 2 (=B) avec la valeur temp(i) comme critère

    '''ENTETE LIGNE (6) DU TABLEAU'''

    Set dics = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dics
    For Each cel In pl.Offset(0, 1).SpecialCells(xlCellTypeVisible) 'boucle 2 : sur toutes les cellules visibles cel de la plage pl déclalée d'un colonne à droite
        dics(cel.Value) = "" 'alimente le dictionnaire dics
    Next cel 'prochaine cellule de la boucle 2
teo = dics.keys 'définit le tabeau teo
    
    ''DEBUT ENTETE DU TABLEAU 1ERE PARTIE
    
    o.Range("A6") = "Localisation"
    o.Range("A7") = "Localisation"
    
    o.Range("B6") = "Alimentation"
    o.Range("C6") = "Alimentation"
    
    o.Range("B7") = "Tension" & Chr(10) & "(Volt)"
    o.Range("C7") = "Courant" & Chr(10) & "(Ampère)"
       
    ''SUITE TABLEAU EXTRAITE DE LA BD'''''''''''''''''''''''''''''
    
    y = 2 'initialise la variable y
    For x = 0 To UBound(teo) 'boucle 3 : sur toutes les outils (sans doublon)
        o.Cells(6, y + 2).Value = teo(x) 'place l'outil dans le tableau
        o.Cells(6, y + 2).Offset(, 1).Value = teo(x) 'place l'outil dans le tableau
        
        o.Cells(7, y + 2).Value = "Potentiel" & Chr(10) & "(mV)"
        o.Cells(7, y + 2).Offset(, 1).Value = "Courant" & Chr(10) & "(mA)"
    y = y + 2 'incrément y
        
        'o.Cells(7, y + 2).Offset(-1, 0).Offset(1, 0).Value = "Direction"
        'o.Cells(7, y + 3).Offset(-1, 0).Value = "Observations"
     
     ''FIN entete ligne DU TABLEAU'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     dercol = o.Range("A6").End(xlToRight).Column
     o.Cells(6, dercol + 1).Value = "Direction"
     o.Cells(6, dercol + 1).Offset(, 1).Value = "Observations"
     o.Cells(7, dercol + 1).Value = "Direction"
     o.Cells(7, dercol + 1).Offset(, 1).Value = "Observations"
     

    Next x 'prochain outil de la boucle 3

    '''ENTETE COLONNE (A) DU TABLEAU''''''''''''''''''''''''''''    
    Set dics = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dics
    For Each cel In pl.Offset(0, 2).SpecialCells(xlCellTypeVisible) 'boucle 2 : sur toutes les cellules visibles cel de la plage pl déclalée d'un colonne à droite
        dics(cel.Value) = "" 'alimente le dictionnaire dics
    Next cel 'prochaine cellule de la boucle 2
    
    o.Range("A8").Resize(dics.Count) = Application.Transpose(dics.keys) 'renvoie en colonne à partir de A2 la liste des outils sans doublons
     
     ' je bloque à ce niveau
    'o.Range("B8").Resize(Item.Count) = Application.Transpose(dics.items)

    bd.Range("A1").AutoFilter 'annule le filtre automatique
Next i 'prochaine valeur de la boucle 1
End Sub 

Donc, Avec ce code on transfère les données De la feuille source, colonne B représente le nom des feuilles où seront transférées les données.
- colonne C transfert en ligne sur chaque feuille de destination
- colonne D transfert en colonne A sur chaque feuille de destination

*manque transfert Colonne F et G, en colonne B et C sur chaque feuilles de destination.

Transfere données "disposition source" et "dispositions destination" différentes

5 réponses

Votre réponse

Discussions similaires