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

Signaler
Messages postés
2
Date d'inscription
lundi 26 août 2013
Statut
Membre
Dernière intervention
26 août 2013
-
 sandero1970 -
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.

3 réponses

Messages postés
3334
Date d'inscription
samedi 20 juillet 2013
Statut
Membre
Dernière intervention
9 décembre 2016
514
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+
Messages postés
2
Date d'inscription
lundi 26 août 2013
Statut
Membre
Dernière intervention
26 août 2013

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
Messages postés
3334
Date d'inscription
samedi 20 juillet 2013
Statut
Membre
Dernière intervention
9 décembre 2016
514
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+
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