VBA : transfert de donnée selon "valeur"

eglantine217 Messages postés 64 Statut Membre -  
f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour,

J'ai un petit problème de code VBA et j'aurai besoin d'aide. Dans un tableau excel j'ai un ensemble de données avec en colonne G différentes valeurs (valeur1, valeur2, valeur3, valeur4). J'aurai aimé faire un seul et unique code qui selon la valeur de la colonne G copie et colle ces valeurs dans l'onglet correspondant exemple valeur1 en colonne G tout ira dans l'onglet 2 ; valeur2 en colonne G tout ira dans l'onglet 3 et ainsi de suite tout en respectant mon code ci-dessous. C'est vraiment compliqué mais je vous remercie d'avance ! 

Sub transfert_valeur1()

Const nomFO = "DB_monthyear"     'nom de l'onglet de départ

Const nomFD = "valeur1_data"       'nom de l'onglet d'arrivée

Const CellD1 = "C12"           'cellule départ 1

Const CellD2 = "D12"           'cellule départ 2

Const CellD3 = "I12"           'cellule départ 3

Const CellD4 = "B12"           'cellule départ 4

Const CellD5 = "U12"           'cellule départ 5


Dim lifin As Long

Dim lifin2 As Long

Dim lifin3 As Long

Dim lifin4 As Long

Dim lifin5 As Long



lifin = Range("F" & Rows.Count).End(xlUp).Row

lifin2 = Range("A" & Rows.Count).End(xlUp).Row

lifin3 = Range("H" & Rows.Count).End(xlUp).Row

lifin4 = Range("T" & Rows.Count).End(xlUp).Row

lifin5 = Range("AA" & Rows.Count).End(xlUp).Row

Sheets(nomFO).Range("F7:F" & lifin).Copy Sheets(nomFD).Range(CellD1)


Sheets(nomFO).Range("A7:E" & lifin2).Copy Sheets(nomFD).Range(CellD2)


Sheets(nomFO).Range("H7:S" & lifin3).Copy Sheets(nomFD).Range(CellD3)


Sheets(nomFO).Range("T7:T" & lifin4).Copy Sheets(nomFD).Range(CellD4)

Sheets(nomFO).Range("U7:AA" & lifin5).Copy Sheets(nomFD).Range(CellD5)


End Sub

3 réponses

  1.
    f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Bonjour,
    qui selon la valeur de la colonne G Vous pouvez preciser????
    0
    1. eglantine217 Messages postés 64 Statut Membre
       
      si dans la colonne G on a valeur1 alors toute la ligne est copié vers l'onglet valeur1
      si dans la colonne G on a valeur2 alors toute la ligne est copié vers l'onglet valeur2

      tout en respectant mon code avec le transfert vers les cellules indiquées

      pour le moment j'ai fait 5 boutons et je suis obligé de filtrer sur la colonne G puis de cliquer sur le bon bouton

      c'est vraiment compliqué ...
      0
    2. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
       
      Re,
      Vous voulez dire:
      Chaque fois que dans la colonne G il y a les V1 a V4, il faut copier la ligne dans l'onglet qui a pour nom valeur1 pour V1 et ainsi de suite?
      0
    3. eglantine217 Messages postés 64 Statut Membre
       
      c'est ça alors mon code est OK lorsque je filtre sur la colonne G mais la je voudrai éviter de filtrer quatre fois et d'avoir 4 boutons différents

      j'aimerai que le copier coller se fasse directement si c'est V1 alors la ligne part dans l'onglet V1 etc ...
      0
  2. alena20 Messages postés 24 Statut Membre 2
     
    Bonjour,

    Si j'ai bien compris, vous voulez nomer les feuilles selon les valuers ds le col G. Donc le code est comme suivante: 

    
Sub ValeurSheet()


Dim ssheetname As String
Dim n As Long, lastrow As Long
Dim ssheet1 As Worksheet

Set ssheet1 = Sheets("DB_monthyear")

'search last row in the col G

lastrow = ssheet1.Cells.Find(What:="*", After:=[G1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'start the boucle of the values in the col G

For i = 1 To lastrow
   
'remember the name of the value in col G

ssheetname = ssheet1.Cells(i, 7)

'n=calculates number of sheets with name=ssheetname.In the beginning of the boucle of the sheets reset the value of n

    n = 0
    For Each Worksheet In Worksheets
        If Worksheet.Name = ssheetname Then
            n = n + 1
        End If
           
    Next Worksheet
    If n < 1 Then
             Sheets.Add.Move After:=Sheets(Sheets.Count)
             ActiveSheet.Name = ssheetname
           End If
Next i

           
 End Sub


    Je l'ai essayé.,Ca doit marcher. Si vous voulez je peux vous l'envoyer la feuille avec le code.
    Cord,Alena
    0
    1. eglantine217 Messages postés 64 Statut Membre
       
      non c'est pas ça mais votre réponse correspond à une autre question que je me pose ! merci pour le code

      moi je veux actuellement éviter de filtrer la colonne sur valeur1 puis de coller dans l'onglet V1 je voudrai que le copier coller soit automatiquement c'est à dire la ligne est copié puis collé dans l'onglet correspondant V1 si en G j'ai la valeur ("valeur1) etc ... je suis perdue totalement
      0
    2. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
       
      Re,
      Cela correspond a ce que je vous ai demande. Ca urge ou pas????
      0
    3. eglantine217 Messages postés 64 Statut Membre
       
      je veux que mon copier coller aille dans l'onglet correspondant à la valeur dans la colonne G c'est à dire valeur1 la ligne aille dans l'onglet v1 etc
      0
    4. alena20 Messages postés 24 Statut Membre 2
       
      Rebonjour,

      Ok supposons que les feuilles correspondants aux valuers deja existent et que vous voulez copier la valeureX dans le feuille nomé valeureX que une fois a partir de feuille DB_monthyear. J'espere que j'ai bien compris votre demnade cette fois. La valeure sera copier dans la cellule(1,1), mais vous pouvez modifier cette cellule Donc le code est comme suivante; 

      
 Sub ValeurInSheet()  


Dim ssheetname As String, cel As Range  
Dim  lastrow As Long  
Dim ssheet1 As Worksheet  

Set ssheet1 = Sheets("DB_monthyear")  

'search last row in the col G  

lastrow = ssheet1.Cells.Find(What:="*", After:=[G1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row  

'start the boucle of the values in the col G  

For i = 1 To lastrow  
     
'remember the name of the value in col G  

ssheetname = ssheet1.Cells(i, 7)  


    For Each Worksheet In Worksheets  
        If Worksheet.Name = ssheetname Then  'compares value in col G with the name of excel sheet
            Worksheet.Activate  
            Set cel = ActiveSheet.Cells.Columns(1).Find(What:=ssheetname)  'checks whether there is already valueX in sheet valueX
                If cel Is Nothing Then  'if there is no yet valueX copies in sheet valueX, then it will copy it
                    Cells(1, 1) = ssheetname  
                End If  
        End If  
    Next Worksheet  
             
Next i  

             
End Sub


      Cord, Alena
      0
  3. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Re,

    Si j'ai compris ce que vous voulez, un exemple de code. 
    Sub copier_coller()
  Dim cel As Range, Plage As Range
  
  With Worksheets("DB_monthyear")
    'derniere ligne Datas
    derlig = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    'Definition plage de recherche
    Set Plage = .Range("G7:G" & derlig)
  
    For Each cel In Plage
      Valeur = cel.Text
      'derniere ligne Onglet Vx
      DLC = Worksheets(Valeur).Range("C" & Rows.Count).End(xlUp).Row + 1
      If DLC < 12 Then DLC = 12
      DLD = Worksheets(Valeur).Range("D" & Rows.Count).End(xlUp).Row + 1
      If DLD < 12 Then DLD = 12
      DLI = Worksheets(Valeur).Range("I" & Rows.Count).End(xlUp).Row + 1
      If DLI < 12 Then DLI = 12
      DLB = Worksheets(Valeur).Range("B" & Rows.Count).End(xlUp).Row + 1
      If DLB < 12 Then DLB = 12
      DLU = Worksheets(Valeur).Range("U" & Rows.Count).End(xlUp).Row + 1
      If DLU < 12 Then DLU = 12
      'copie des cellules
      If .Cells(cel.Row, "F") <> "" Then
        .Cells(cel.Row, "F").Copy Worksheets(Valeur).Range("C" & DLC)
      End If
      If .Cells(cel.Row, "A") <> "" Then
        .Cells(cel.Row, "A").Copy Worksheets(Valeur).Range("D" & DLD)
      End If
      If .Cells(cel.Row, "H") <> "" Then
        .Cells(cel.Row, "H").Copy Worksheets(Valeur).Range("I" & DLI)
      End If
      If .Cells(cel.Row, "T") <> "" Then
        .Cells(cel.Row, "T").Copy Worksheets(Valeur).Range("B" & DLB)
      End If
      If .Cells(cel.Row, "U") <> "" Then
        .Cells(cel.Row, "U").Copy Worksheets(Valeur).Range("U" & DLU)
      End If
    Next cel
  End With
End Sub


    A+
    0

Discussions similaires

erreur d'execution 9, l'indice n'appartient pas à la sélection
isidoh -
isidoh -

18 réponses
VBA excel : résoudre problème de capacité.
Juan Pedro -
Kunzi -

9 réponses
"L'indice n'appartient à la sélection" + VBA
fleur.31 -
geosevda -

2 réponses
Méthode find dans VBA - Recherche de données sous Excel
baissaoui -
baissaoui -

0 réponse
Erreur d'exécution 13 Incompatibilité de type
grace -
pijaku -

5 réponses