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.

3 réponses

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