Re : Copier/coller une cellule dans une autre avec boucle for each
Bonjour,
J'ai réussi à me dépatouiller de mon code.
Il fallait réactiver la fenêtre pour la boucle for each.
Je met donc mon code à disposition.
Sub PLANNING()
Dim WbkS As Workbook ' Classeur source
Dim WbkD As Workbook ' Classeur de Destination
Dim VPathFic As String
Dim Cell As Range
' Définir le classeur source
Set WbkS = ThisWorkbook
' Demander de choisir le classeur de Destination
MsgBox "Merci de sélectionner le classeur de Destination !"
' Choisir le fichier à ouvrir
VPathFic = ChoixFichier()
' Si aucun fichier, alors sortir
If VPathFic = "" Then Exit Sub
' Sinon ouvrir le classeur
Workbooks.Open VPathFic
' Définir le classeur de Destination
Set WbkD = ActiveWorkbook
dernligwbkd = WbkD.Sheets(ActiveSheet.Name).Range("A" & Rows.Count).End(xlUp).Row
Windows(WbkS.Name).Activate
' Effectuer la copie / collage de la feuille liste qui fait quoi
dernlig& = Columns(1).Rows(Rows.Count).End(xlUp).Row
NoLig = 0
If dernlig >= 12 Then
For Each Cell In Range("A12:A" & dernlig)
If Cell <> "" Then
NoLig = NoLig + 1
Windows(WbkD.Name).Activate
Cells(NoLig + dernligwbkd, 1) = "AO"
WbkS.Sheets("Liste qui fait quoi").Range(Range(Cell.Address).Offset(0, 9).Address).Copy
WbkD.Sheets(ActiveSheet.Name).Cells(NoLig + dernligwbkd, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WbkS.Sheets("Liste qui fait quoi").Range(Range(Cell.Address).Offset(0, 10).Address).Copy
WbkD.Sheets(ActiveSheet.Name).Cells(NoLig + dernligwbkd, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WbkS.Sheets("Liste qui fait quoi").Range(Range(Cell.Address).Offset(0, 3).Address).Copy
WbkD.Sheets(ActiveSheet.Name).Cells(NoLig + dernligwbkd, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WbkS.Sheets("Liste qui fait quoi").Range(Range(Cell.Address).Offset(0, 2).Address).Copy
WbkD.Sheets(ActiveSheet.Name).Cells(NoLig + dernligwbkd, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WbkS.Sheets("Liste qui fait quoi").Range(Range(Cell.Address).Offset(0, 4).Address).Copy
WbkD.Sheets(ActiveSheet.Name).Cells(NoLig + dernligwbkd, 7).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WbkS.Sheets("Liste qui fait quoi").Range(Range(Cell.Address).Offset(0, 15).Address).Copy
WbkD.Sheets(ActiveSheet.Name).Cells(NoLig + dernligwbkd, 9).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WbkS.Sheets("Liste qui fait quoi").Range(Range(Cell.Address).Offset(0, 15).Address).Copy
WbkD.Sheets(ActiveSheet.Name).Cells(NoLig + dernligwbkd, 10).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Windows(WbkS.Name).Activate
End If
Next
End If
Application.CutCopyMode = False
' Message de fin
MsgBox "La mise à jour du planning est terminée"
' effacer les variables objet
Set WbkD = Nothing
Set WbkS = Nothing
End Sub
Function ChoixFichier()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
If .Show = -1 Then
ChoixFichier = fd.SelectedItems(1)
Else
ChoixFichier = ""
End If
End With
Set fd = Nothing
End Function
Merci encore.