COPIER/ COLLER RANGE variable dans des onglets différents VBA
Résolu
sandero1970
Messages postés
2
Date d'inscription
Statut
Membre
Dernière intervention
-
sandero1970 -
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.
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
- Historique copier coller - Guide
- Copier coller pdf - Guide
- Copier-coller - Accueil - Informatique
- Style d'écriture a copier coller - Guide
- Symbole clavier copier coller - Guide
3 réponses
Bonjour,
A+
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+
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
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
Tu peux tester comme cela.
Sans exemple je n'irai pas plus loin.
A+
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
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