1ère macro - Copie de lignes d'une feuille à une autre

Bonjour,

J'essaie de faire une 1er macro, et évidemment, elle plante.

Dans le fichier joint, il y a 2 feuilles.

L'idée est de récupérer, pour un mois donné (valeur spécifiée dans la feuille "Extraction"), toutes les taches qui se déroulent pendant le mois spécifié, et de copier/coller les infos correspondantes (tache, début, durée, fin, acteur...) dans la feuille "extraction"...

Voici la macro que je suis en train d'écrire:

Sub extraire()

Dim i_max As Integer

Dim i As Integer

Dim ligne As Integer

Dim mois_date As Date

'Obtention du nombre de lignes de la feuille "Planning"

i_max = Worksheets("Planning").Range("A" & Rows.Count).End(xlUp).Row

i = 1

ligne = 4

mois_date = Worksheets("Extraction").Range(Cells(3, 2)).Value

For i = 1 To i_max

If mois_date < Range(Cells(i, "D")).Value Then

If mois_date >= Range(Cells(i, "B")).Value Then

Worksheets("Planning").Range(Cells(i, 1), Cells(i, 5)).copy_

Worksheets("Extraction").Range ("A6")

End If

End If

Next i

End Sub

Merci!

Salut,

Tu fais référence aux cellules de plusieurs manières incorrectes

Range(Cells(3, 2))
Range(Cells(i, "D"))

Voici deux manière de le faire correctement

Range(Cells(3, 2), Cells(3, 2))
Range("B3")

Il n’est pas absolument nécessaire d’utiliser .Value pour ce que tu désires faire ici.

Le passage ci-dessous va probablement planter

            Worksheets("Planning").Range(Cells(i, 1), Cells(i, 5)).copy_
            Worksheets("Extraction").Range ("A6")

Essaie plutôt

Worksheets("Planning").Range(Cells(i, 1), Cells(i, 5)).Copy Destination:=Worksheets("Extraction").Range ("A6")

Cordialement

Bonjour, Bonjour Yvouille,

En complément des infos précédentes

Cdlt

Option Explicit
Public Sub extraire()
Dim wS_1 As Worksheet, wS_2 As Worksheet
Dim derLigne As Integer
Dim i As Integer
Dim Mois As Date

    Set wS_1 = Worksheets("Planning")
    Set wS_2 = Worksheets("Extraction")
    derLigne = wS_1.Range("A" & Rows.Count).End(xlUp).Row
    Mois = wS_2.Cells(3, 2)

    For i = 1 To derLigne
        With wS_1
            If Mois < .Cells(i, 4) And Mois >= .Cells(i, 2) Then _
            .Range(.Cells(i, 1), .Cells(i, 5)).Copy Destination:=wS_2.Cells(6, 1)
        End With
    Next i

    Set wS_1 = Nothing: Set wS_2 = Nothing
End Sub

Bonjour,

Merci pour vos explications.

Je comprends mieux la structure du "programme".

Par contre, il y a plusieurs soucis:

• quelques fois, des lignes sont copiées alors qu'elles ne correspondent pas à la date entrée
• je souhaiterais que les lignes soient ajoutées les unes après les autres. C'est pour cela que j'ai ajouté un compteur supplémentaire J
• à chaque fois que j'ouvre le fichier et execute la macro, il y a une erreur. Je suis obligé de réaffecter la macro au bouton crée pour que cela fonctionne de nouveau.

Je vous joins le fichier.

Merci.

Help!

J'ai beau chercher, mais je n'arrive pas à résoudre mes problèmes.

Bonjour

Modifies ton code

Public Sub extraire()
Dim wS_1 As Worksheet, wS_2 As Worksheet
Dim derLigne As Integer
Dim i As Integer
Dim j As Integer
Dim Mois As Date

  Set wS_1 = Worksheets("Planning")
  Set wS_2 = Worksheets("Extraction")
  derLigne = wS_1.Range("A" & Rows.Count).End(xlUp).Row
  Mois = wS_2.Cells(3, 2)
  j = 6

  For i = 1 To derLigne
    With wS_1
      If Mois < .Cells(i, 4) And Mois >= .Cells(i, 2) Then
        j = j + 1
        .Range(.Cells(i, 1), .Cells(i, 5)).Copy Destination:=wS_2.Cells(j, 1)
      End If
    End With
  Next i
  Set wS_1 = Nothing: Set wS_2 = Nothing
End Sub

Désolé pour ma réponse tardive.

Cela fonction presque à 100%...

Il y a juste un souci.

Supposons que je lance la macro pour le mois de 04/2014, il va m'extraire 10 lignes.

Si je la relance dans la foulée pour un autre mois avec 3 lignes, il va bien me copier les 3 lignes, mais il restera les 7 lignes de l'extraction précédente.

J'ai donc ajouté une commande permettant de supprimer les lignes au début de la macro.

Cela fonctionne, mais une fois la macro terminée, les lignes restent sélectionnées...

Comment éviter cela?

Voici mon code:

   Public Sub extraire()
    Dim wS_1 As Worksheet, wS_2 As Worksheet
    Dim derLigne As Integer
    Dim i As Integer
    Dim j As Integer
    Dim Mois As Date

      Set wS_1 = Worksheets("Planning")
      Set wS_2 = Worksheets("Extraction")
      derLigne = wS_1.Range("A" & Rows.Count).End(xlUp).Row
      Mois = wS_2.Cells(3, 2)
      j = 6
      Rows("7:" & derLigne).Select
      Selection.Delete Shift:=xlUp
      For i = 1 To derLigne
        With wS_1
          If Mois < .Cells(i, 4) And Mois >= .Cells(i, 2) Then
            j = j + 1
            .Range(.Cells(i, 1), .Cells(i, 5)).Copy Destination:=wS_2.Cells(j, 1)
          End If
        End With
      Next i
      Set wS_1 = Nothing: Set wS_2 = Nothing
    End Sub

Bonjour

Essayes

Public Sub extraire()
Dim wS_1 As Worksheet, wS_2 As Worksheet
Dim derLigne As Integer
Dim i As Long
Dim j As Long
Dim Mois As Date

  Application.ScreenUpdating = False
  Set wS_1 = Worksheets("Planning")
  Set wS_2 = Worksheets("Extraction")

  With wS_2
    If .Range("A7") <> "" Then
      With .Range("A7:E" & .Range("A" & Rows.Count).End(xlUp).Row)
        .ClearContents
        .Borders.LineStyle = xlNone
      End With
    End If
  End With

  derLigne = wS_1.Range("A" & Rows.Count).End(xlUp).Row
  Mois = wS_2.Cells(3, 2)
  j = 6

  With wS_1
    For i = 1 To derLigne
      If Mois < .Cells(i, 4) And Mois >= .Cells(i, 2) Then
        j = j + 1
        .Range(.Cells(i, 1), .Cells(i, 5)).Copy
        wS_2.Range("A" & j).PasteSpecial Paste:=xlPasteValues                       
        wS_2.Range("A" & j).PasteSpecial Paste:=xlPasteFormats                        
      End If
    Next i
  End With
  Application.CutCopyMode = False
  wS_2.Range("B3").Select
  Set wS_1 = Nothing: Set wS_2 = Nothing
End Sub

Bonjour,

Encore merci. Cela fonctionne parfaitement.

Enfin presque

Le remplissage d'une cellule n'est pas supprimé.

La cellule reste donc colorée, même si cela n'a pas lieu d'être:

Bonjour

Rajoutes la ligne surlignée

  With wS_2
    If .Range("A7") <> "" Then
      With .Range("A7:E" & .Range("A" & Rows.Count).End(xlUp).Row)
        .ClearContents
        .Borders.LineStyle = xlNone
        .Interior.ColorIndex = xlNone
      End With
    End If
  End With

Ça fonctionne nickel.

Merci!