macro copier des cellules et les coller dans les bonnes cellules d'un tableau ex

Question

Bonjour,

J'aurai besoin d'un petit coup de pouce pour ma macro, J'ai une feuille Excel pour laquelle j'ai les données d'entrées suivantes :

      A      B      C      D      E                        Q
1           000    001    002    003                      A5310AB001.PDF
2   A5310                                                 A5311AD000.TIF
3   A5311                                                 A3210FG002.TIF
4   A5321                                                 A3210FD001.PDF
5   A3210                                                 A5321TT003.TIF

(sachant que A,B,etc sont les colonnes d'excel et 1,2,3,.. sont les lignes excel). Les 000 001 002 et A5310, A5311 .. sont les libellés d'un tableau. La colonne Q contient des noms de fichiers et sont sous forme de lien hypertexte.

Je voudrais que la macro me copie les noms de fichier + lien de la colonne Q au bon endroit dans le tableau. Comme ci dessous :

      A      B              C               D               E
1           000             001             002             003
2   A5310                   A5310AB001.PDF                         
3   A5311   A5311AD000.TIF                                              
4   A5321                                                   A5321TT003.TIF 
5   A3210                   A3210FD001.PDF  A3210FG002.TIF


Voilà, j'ai essayé d'être le plus clair possible, merci d'avance à ceux qui se pencheront sur mon sujet.
Ma conf : Excel 2003 et/ou open office, vba

ginestetromain · Answer

pardon, les tableau des mon premier message se sont mal mis en forme, après correction ca donne ça (je ne sais pas comment supprimer mon premier message).
-------------------------------------------------------------------------
Bonjour,

J'aurai besoin d'un petit coup de pouce pour ma macro, J'ai une feuille Excel pour laquelle j'ai les données d'entrées suivantes :

____A_____B_______C_______D______E________________________Q
1_________000_____001_____002____003______________________A5310AB001.PDF
2___A5310_________________________________________________A5311AD000.TIF
3___A5311_________________________________________________A3210FG002.TIF
4___A5321_________________________________________________A3210FD001.PDF
5___A3210_________________________________________________A5321TT003.TIF

(sachant que A,B,etc sont les colonnes d'excel et 1,2,3,.. sont les lignes excel). Les 000 001 002 et A5310, A5311 .. sont les libellés d'un tableau. La colonne Q contient des noms de fichiers et sont sous forme de lien hypertexte.

Je voudrais que la macro me copie les noms de fichier + lien de la colonne Q au bon endroit dans le tableau. Comme ci dessous :

____A_______B_______________C_______________D_______________E
1___________000_____________001_____________002_____________003
2___A5310___________________A5310AB001.PDF                         
3___A5311___A5311AD000.TIF                                              
4___A5321___________________________________________________A5321TT003.TIF 
5___A3210___________________A3210FD001.PDF__A3210FG002.TIF


Voilà, j'ai essayé d'être le plus clair possible, merci d'avance à ceux qui se pencheront sur mon sujet.
Ma conf : Excel 2003 et/ou open office, vba

cs_Le Pivert · Answer

Bonjour,
J'ai fait une macro qui utilise: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
il faut cliquer sur les cellules de la colonne A  pour que les liens hypertextes correspondants se positionnent dans les colonnes choisies.
Pour cela il faut mettre un checkBox sur la feuille 1 pour activer quand on veut saisir des données et désactiver pour activer la macro.
Voici le code à mettre dans la feuille1:

Dim nom_2 As String
Dim nom As String
Dim chiffre As Integer
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 On Error Resume Next
 If CheckBox1.Value = True Then Exit Sub
 
 nom = Target.Address
    If Target.Address = nom Then
        nom = Target.Value
      FindIt
      Target.Select
      transChiffre
     If chiffre = "0" Then
     ActiveCell.Offset(0, 1).Select ' à droite (0 même ligne, 1 col à droite)
   ElseIf chiffre = "1" Then
     ActiveCell.Offset(0, 2).Select ' à droite (0 même ligne, 2 col à droite)
      ElseIf chiffre = "2" Then
     ActiveCell.Offset(0, 3).Select ' à droite (0 même ligne, 3 col à droite)
      ElseIf chiffre = "3" Then
     ActiveCell.Offset(0, 4).Select ' à droite (0 même ligne, 4 col à droite)
    End If
    ActiveSheet.Paste
    End If
     CheckBox1.Value = False
     End Sub
Private Sub FindIt()
 Dim oRange As Range
Dim vRow As Variant
  If nom = "" Then Exit Sub
Feuil1.Activate
   CheckBox1.Value = True
  Set oRange = Feuil1.Range("Q:Q")
'Trouvez le contenu de la cellule complète
 ' vRow = Application.Match(nom, oRange, False)

  'Trouver dans une partie du contenu de la cellule
  vRow = Application.Match("*" & nom & "*", oRange, False)

  If IsError(vRow) Then
     'MsgBox "Non trouvé"
  Else
   Feuil1.Range("Q" & vRow).Select
  Selection.Copy
  nom_2 = Selection.Value
 End If
 End Sub
  Sub transChiffre()
   On Error Resume Next
   s = nom_2
  For I = 1 To Len(s)
    If IsNumeric(Mid(s, I, I)) Then  'separer l'alpha et les numeric
    lettre = Mid(s, 10, I - 1)
    numero = Mid(s, I, Len(s))
    GoTo suit
    End If
    Next
suit:
chiffre = lettre
End Sub

J'espère avoir été assez clair. J'ai essayé avec une boucle sur la colonne q, mais cela n'a pas marché.
@+ Le Pivert

cs_Le Pivert · Answer

J'ai pensé que si tes liens hypertextes n'ont pas le même nombre de caractères, il y aura une erreur la macro étant basée sur le fait que le chiffre se trouve à la 10ème place.
Voici donc une nouvelle macro qui enlève les 3 dernières lettre et le point pour ne garder que les chiffres ensuite on cherche le dernier chiffre:

 Dim resultat As String
 Sub transChiffre()
   On Error Resume Next
   s = "A5311AD003.TIF"
 For I = 1 To Len(s)
    If IsNumeric(Mid(s, I, I)) Then  'separer l'alpha et les numeric
    lettre = Mid(s, 10, I - 1)
    numero = Mid(s, I, Len(s) - 5) 'on enlève les dernières lettres et le point
    GoTo suit
    End If
    Next
suit:
MsgBox numero
resultat = numero
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
dernierChiffre
End Sub
Sub dernierChiffre()
    Dim chiffre As String
    Dim lenChiffre As Integer
    Dim droiteChiffre As String
    Dim cel As Range
    Dim Pdecimale As String
transChiffre
For Each cel In Selection

    chiffre = resultat
    lenChiffre = Len(chiffre)
    droiteChiffre = Right(chiffre, 1)
    pos = InStr(1, chiffre, ".")
    Pdecimale = Mid(chiffre, pos + 1)
    nbzero = Len(Pdecimale) - 1
    zero = Application.WorksheetFunction.Rept("0", nbzero)
   ' cel.Offset(0, 1).Value = "0." & zero & droiteChiffre
MsgBox droiteChiffre

Next cel

End Sub


J'espère que cela te sera utile

@+ Le Pivert

cs_Le Pivert · Answer

J'ai réussi a faire une boucle sur la colonne A. Au départ je l'avait fait sur la colonne Q et cela ne fonctionnait pas.
J'ai mis pas mal de commentaires pour que tu comprennes bien la marche à suivre. Il faudra que tu redimensionnes les colonnes manuellement car AutoFit ne fonctione pas.
A mettre dans un module:
Dim nom_2 As String
Dim nom As String
Dim chiffre As Integer
Sub BouclePlagesCellules()
     'Définit une variable qui va représenter un classeur
    Dim Wb As Workbook
    'Définit une variable qui va représenter une feuille de calcul
    Dim Ws As Worksheet
    'Définit une variable qui va représenter une cellule
    Dim Cell As Range
     'Boucle sur chaque classeur de l'application Excel
    For Each Wb In Application.Workbooks
        'Boucle sur chaque feuille de chaque classeur
        For Each Ws In Wb.Worksheets
            'Boucle sur chaque cellule de la colonne A
            For Each Cell In Ws.Range("A:A")
               If Cell.Value = "" Then Exit Sub
               Cell.Select 'selection cellule colonne A
     nom = Cell.Value 'nom cellule colonne A
       FindIt 'recherche du nom
        Cell.Select 'selection cellule colonne A
        transChiffre 'recherche du dernier chifre
     If chiffre = "0" Then
     ActiveCell.Offset(0, 1).Select ' à droite (0 même ligne, 1 1 col à droite)
   ElseIf chiffre = "1" Then
     ActiveCell.Offset(0, 2).Select ' à droite (0 même ligne, 2 2 col à droite)
      ElseIf chiffre = "2" Then
     ActiveCell.Offset(0, 3).Select ' à droite (0 même ligne, 3 3 col à droite)
      ElseIf chiffre = "3" Then
     ActiveCell.Offset(0, 4).Select ' à droite (0 même ligne, 4 4 col à droite)
    End If
    ActiveSheet.Paste 'on colle
 Next Cell
        Next Ws
    Next Wb
  End Sub
 Private Sub FindIt()
 Dim oRange As Range
Dim vRow As Variant
  If nom = "" Then Exit Sub
Feuil1.Activate
   Set oRange = Feuil1.Range("Q:Q")
'Trouvez le contenu de la cellule complète
 ' vRow = Application.Match(nom, oRange, False)

  'Trouver dans une partie du contenu de la cellule
  vRow = Application.Match("*" & nom & "*", oRange, False)

  If IsError(vRow) Then
     'MsgBox "Non trouvé"
  Else
   Feuil1.Range("Q" & vRow).Select
  Selection.Copy 'on copie
  nom_2 = Selection.Value 'nom de l'hypertexte
 End If
 End Sub
  Sub transChiffre()
   On Error Resume Next
   s = nom_2 'nom de l'hypertexte
  For I = 1 To Len(s)
    If IsNumeric(Mid(s, I, I)) Then  'separer l'alpha et les numeric
    lettre = Mid(s, 10, I - 1) '10ème caractère
    numero = Mid(s, I, Len(s))
    GoTo suit
    End If
    Next
suit:
chiffre = lettre ' dernier caractère
End Sub




Tu appelles par la macro:

Private Sub CommandButton1_Click()
BouclePlagesCellules
End Sub



@+ Le Pivert

ginestetromain · Answer

Salut Le Pivert

C'est ce que je voulais à un détail près c'est qu'il y a 2 hypertextes nommé A3210 (le A3210FG002 et le A3210FG001), ta macro ne prend que le premier qu'il trouve dans la colonne QQ.

Je vais chercher un peu quand même car tu m'as tout écrit pour le moment. Mais si tu trouves un truc je ne suis pas contre.
Encore un grand merci pour tout ce que tu fais!! Pour moi c'est un gain de temps non négligeable.

A bientôt sur la toile.

cs_Le Pivert · Answer

Oui, je m'en suis aperçu aussi, mais la recherche se fait sur "A3210", donc elle ne se trompe pas. Il faut donc renommer  les 2 "A3210"
en "A3210FG"  et "A3210FD"

@+ Le Pivert

Macro copier des cellules et les coller dans les bonnes cellules d'un tableau ex

6 réponses

Votre réponse

Discussions similaires