Copier/coller une cellule dans une autre avec boucle for each

[jerem512]

Bonjour,


Je vous explique ma problématique. J'ai un planning dans lequel je rassemble plusieurs projet.
Je souhaite copier/coller des cellules dans un autre planning si et seulement si la cellule en face est rempli.

J 'ai commencé à faire un code mais il ne fonctionne pas.

Le voici:


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
' Effectuer la copie / collage de chaque feuille

For Each Cell In Range("A12:A" & Range("A500").End(xlUp).Row)
If Cell <> "" Then

WbkS.Sheets("Liste qui fait quoi").Cell.Offset(0, 1).Copy Destination:=WbkD.Sheets("Table").Range("A1")

End If
Next Cell

' Message de fin
MsgBox "La copie du classeur source vers le calsseur de destination 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


La ligne qui bloque est la suivante:
WbkS.Sheets("Liste qui fait quoi").Cell.Offset(0, 1).Copy Destination:=WbkD.Sheets("Table").Range("A1")

L 'erreur est: Erreur d’exécution 438

Également, actuellement ma macro ne fait la copie que sur une seule cellule ( Range("A1") ) seulement je voudrais qu'avec le "for each" la copie ce fasse en A1 puis B1 puis C1.

En espérant avoir un retour.
Merci

 

[Roland_M]

Re : Copier/coller une cellule dans une autre avec boucle for each

re

je ne comprends pas car chez moi ça fonctionne !?
j'ai créé la feuille Table, pour faire un essai,
j'ai mis des valeurs dans la colonne(A) car tu n'as aucune donnée
et de ce fait je ne suis pas étonné que ça ne copie rien !?

car la boucle test si il y a une valeur dans cette colonne A comme tu l'as demandé, mais tu n'as rien dedans donc ça ne copie rien !?

c'est pour cela que je t'avais demandé s'il s'agissait bien de tester la colonne A et copier ce qu'il y avait en colonne B !?

tu es certain qu'il faut tester les valeurs en colonne A car comme tu peux le voir elle est vide !?
ça ne serait pas plutôt la colonne B (avec Code) et copier la colonne C (client) ?

 

[jerem512]

Re : Copier/coller une cellule dans une autre avec boucle for each

're,
Il a bien une valeur dans la colonne.
Je l'a rempli par un "x" ou non.
En faisant le test avec F8
Le then passe direct en end if.

Puis je avoir le fichier que tu as fait?
merci d'avance

 

[Roland_M]

Re : Copier/coller une cellule dans une autre avec boucle for each

re

je vais t'envoyer le fichier avec la macro en essai que tu pourras tester !
à tout de suite !

 

[Roland_M]

Re : Copier/coller une cellule dans une autre avec boucle for each

re

msg supprimé !

 

[jerem512]

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.