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

Question

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.

Gyrus · Answer

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+

sandero1970 · Answer

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

Gyrus · Answer

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+

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

3 réponses

Discussions similaires