COPIER/ COLLER RANGE variable dans des onglets différents VBA

Résolu/Fermé

sandero1970 Messages postés 2 Date d'inscription lundi 26 août 2013 Statut Membre Dernière intervention 26 août 2013 - 26 août 2013 à 10:25
sandero1970 - 26 août 2013 à 16:27

Bonjour,
Je suis coincé dans une macro EXCEL en VBA pour copier des cellules dans une feuille différenter en fonction d'une référence. Voic le tableau dans ma feuille "CV":

Feuille PC_nbr Name Status

P1 P1_C1 NTBA P1_C1 STBA P1_C1

P1 P1_C2 NTBA P1_C2 STBA P1_C2

P1 P1_C3 NTBA P1_C3 STBA P1_C3

P2 P2_C1 NTBA P2_C1 STBA P2_C1

P2 P2_C2 NTBA P2_C2 STBA P2_C2

P2 P2_C3 NTBA P2_C3 STBA P2_C3

P2 P2_C4 NTBA P2_C4 STBA P2_C4

P3 P3_C1 NTBA P3_C1 STBA P3_C1

Le but est que le loop lise ligne par ligne et copie (par exemple pour le sheet P1 dans colonne 1)les colonnes 3 et 4 (transposées) dans la cellule (B2:i3) avec i= nombre de colonnes qui doit âtre égal au nombre de lignes de mon sheet CV pour le quel la cellule Ai= P1.

Ainsi de suite pour chaque sheet (de P1 à P30). J'ai bien ceci mais le loop s'arrête à 2 sheets:
Public Sub CopyRows()
Dim x As Integer
Dim ThisValue As String

Sheets("Consultants").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 4).Value
If ThisValue = "P1" Then
Cells(x, 1).Resize(1, 33).Copy '??? je me demande à quoi ca sert???
Sheets("P1").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 '??? je me demande à quoi ca sert???
Cells(NextRow, 1).Select
ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Consultants").Select
ElseIf ThisValue = "P2" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("P2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Consultants").Select
End If
Next x
End Sub

MERCI à tous pour votre aide.

A voir également:

COPIER/ COLLER RANGE variable dans des onglets différents VBA
Copier coller pdf - Guide
Restaurer onglets chrome - Guide
Copier une vidéo youtube - Guide
Input signal out of range ✓ - Forum Matériel & Système
Ce fichier contient l'historique des livres empruntés à la bibliothèque. combien de titres différents contient-il ? ✓ - Forum Excel

3 réponses

Réponse 1 / 3

Gyrus Messages postés 3334 Date d'inscription samedi 20 juillet 2013 Statut Membre Dernière intervention 9 décembre 2016 523
26 août 2013 à 11:28

Bonjour,

Public Sub CopyRows()
Dim WsS As Worksheet, WsC As Worksheet
Dim FinalRow As Long
Dim FinalCol As Integer
Dim NomFeuille As String
    Set WsS = Worksheets("Consultants")
    FinalRow = WsS.Cells(Rows.Count, 1).End(xlUp).Row
    For x = 2 To FinalRow
        NomFeuille = WsS.Cells(x, 4).Value
        If FeuilleExiste(NomFeuille) Then
            FinalCol = WsS.Cells(x, Columns.Count).End(xlToLeft).Column
            WsS.Range(Cells(x, 1), Cells(x, FinalCol)).Copy
            Set WsC = Worksheets(WsS.Cells(x, 4).Value)
            With WsC
                .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial _
                Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            End With
            Application.CutCopyMode = False
        End If
    Next x
    Set WsC = Nothing: Set WsS = Nothing
End Sub
Function FeuilleExiste(NomFeuille As String) As Boolean
Dim Ws As Worksheet
   FeuilleExiste = False
   For Each Ws In ActiveWorkbook.Worksheets
      If Ws.Name = NomFeuille Then
         FeuilleExiste = True
      End If
   Next
End Function

A+

Réponse 2 / 3

sandero1970 Messages postés 2 Date d'inscription lundi 26 août 2013 Statut Membre Dernière intervention 26 août 2013
26 août 2013 à 13:07

Merci Gyrus,
Ill y a un souci: Il copie bien les bonnes lignes dans la bonne feuille mais au mauvais endroit.
Il copie chaque fois dans la colonne A à la première cellule libre or je voudrais qu'on copie comme suit:

Si dans Consultants on a 3 lignes "P1", je voudrais que les données des colones D et E de ma feuille consultants soient copiées de manière transposées dans une nouvelle colonne en ligne 3 et 4 de la feuille P1.
Donc si mon range de WsS= (D2:E4), je voudrais que
D2:E2 soit copiée dans WsC B3:B4
D3:E3 C3:C4
D4:E4 D3:D4

or ici, D2:E2, est copié en (Ai:Ai+1), D3:E3 en (Ai+2:Ai+3).... ainsi de suite.

Merci pour ton aide

Réponse 3 / 3

Gyrus Messages postés 3334 Date d'inscription samedi 20 juillet 2013 Statut Membre Dernière intervention 9 décembre 2016 523
26 août 2013 à 14:20

Tu peux tester comme cela.

Public Sub CopyRows()
Dim WsS As Worksheet, WsC As Worksheet
Dim FinalRow As Long
Dim FinalCol As Integer
Dim NomFeuille As String
    Set WsS = Worksheets("Consultants")
    FinalRow = WsS.Cells(Rows.Count, 1).End(xlUp).Row
    For x = 2 To FinalRow
        NomFeuille = WsS.Cells(x, 4).Value
        If FeuilleExiste(NomFeuille) Then
            FinalCol = WsS.Cells(x, Columns.Count).End(xlToLeft).Column
            WsS.Range(Cells(x, 1), Cells(x, FinalCol)).Copy
            Set WsC = Worksheets(WsS.Cells(x, 4).Value)
            With WsC
                .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, .Cells(2, Columns.Count).End(xlToLeft).Column + 1).PasteSpecial _
                Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            End With
            Application.CutCopyMode = False
        End If
    Next x
    Set WsC = Nothing: Set WsS = Nothing
End Sub
Function FeuilleExiste(NomFeuille As String) As Boolean
Dim Ws As Worksheet
   FeuilleExiste = False
   For Each Ws In ActiveWorkbook.Worksheets
      If Ws.Name = NomFeuille Then
         FeuilleExiste = True
      End If
   Next
End Function

Sans exemple je n'irai pas plus loin.
A+

sandero1970
26 août 2013 à 16:27

Ai résolu de telle façon:
Sub CopyRowsToColumns()
Dim i, j, line, n As Integer ' n = nameof candidate s = status of candidate n = nbr of CV
'Dim r1, r2 As Range

For i = 1 To 30
n = Sheets("Profiles").Cells(i + 1, 4)
For j = 1 To n
line = 2 'start line after headings
Sheets("P" & i).Cells(line, j + 1) = "Consultant" & j
line = line + 1
Sheets("P" & i).Cells(line, j + 1) = "NTBA " & i & "_C" & j
line = line + 1
Sheets("P" & i).Cells(line, j + 1) = "STBA " & i & "_C" & j
Next j
Next i
End Sub

Discussions similaires

Dessiner avec son clavier et avec des lettres

VBA : Range avec références variables..

Question PIX

programme qui n'affiche pas le mot secret

Comment faire le signe de croix (chrétiens) ?

Discussions similaires

Newsletters