Copies d'une feuille à une autre / Boucles For

Le 08/08/2013 à 18:27

Bonsoir,

Mon problème est le suivant :

Je dispose d'une feuille avec des données brutes "projects data"
Une feuille où je veux compiler selon un critère qui apparaît dans une colonne du fichier de données brutes

L'objectif est d'aller chercher les données en fonction du critère mais aussi du mois d'analyse. A terme la macro sera mis dans divers feuilles comprenant le critère et ira chercher les données dans la feuille de données brutes.

Voici le code que j'ai mis en place :

For i = 9 To 50
month = Cells(33, i).Value

Sheets("Projects Data").Select

LastLign = Range("A" & Rows.Count).End(xlUp).Row
LastMonth = Range("A" & Rows.Count).End(xlUp).Value

'identification de la dernière ligne comprenant la même date que month

    For k = 15 To LastLign
            If Cells(k, 1) = month Then
            LastLignMonth = k
        Exit For
        End If
    Next k

'Si pas de date
If LastLignMonth = 0 Then
Next i

'identification de la première ligne comprenant la même date que month

    For l = 15 To LastLign
        If Cells(l, 1) = month Then
        FirstLign = l
        Exit For
        End If
    Next l

'identification de la colonne comprenant le critère

    For j = 1 To 50
        If Cells(14, j).Value = KPI Then
        critere = j
        Exit For
        End If
    Next j

Range("B" & FirstLign & ":H" & LastLignMonth, FisrtLign & critere& ":" & LastLignMonth & critere).Copy
synthesesheet.Activate
Range("B34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Next i

Un des problèmes majeur c'est que ce code est très lent d'une part (il va checker les lignes une à une) et que je ne sait pas comment aller tester le mois suivant si on ne trouve pas le mois dans les données brutes.

D'autre part, le copier coller ne fonctionne pas non plus !

A votre dispo pour des précisions.

Le 08/08/2013 à 22:18

voici ton code adapté,

je pense avoir compris ce que tu cherchais à faire.

Sub test()
Dim wss As Object, wsp As Object

Set wsp = Worksheets("Projects Data")
Set wss = Worksheets("synthese")

LastLign = wsp.Range("A" & wsp.Rows.Count).End(xlUp).Row
LastMonth = wsp.Range("A" & wsp.Rows.Count).End(xlUp).Value

For i = 9 To 50
lastlignmonth = 0
Mois = wss.Cells(33, i).Value:  ' je pense que la date est dans synthèse à changer si nécessaire

'identification de la dernière ligne comprenant la même date que mois

    For k = LastLign To 15 Step -1
            If wsp.Cells(k, 1) = Mois Then
            lastlignmonth = k
        Exit For
        End If
    Next k

'Si date trouvée on sort de la boucle
If lastlignmonth <> 0 Then Exit For
Next i

If lastlignmonth = 0 Then MsgBox "mois non trouvé": End

'identification de la première ligne comprenant la même date que month

    For l = 15 To LastLign
        If wsp.Cells(l, 1) = Mois Then
        FirstLign = l
        Exit For
        End If
    Next l

'identification de la colonne comprenant le critère

    For j = 9 To 50
        If wsp.Cells(14, j).Value = "KPI" Then
        t = wsp.Cells(14, j).Address
        critere = Mid(t, 2, InStr(2, t, "$") - 2) : critère contient l'identifiant de colonne sous forme de lettre(s)
        Exit For
        End If
    Next j

wsp.Select
Range("B" & FirstLign & ":H" & lastlignmonth & "," & critere & FirstLign & ":" & critere & lastlignmonth).Select
Range(critere & FirstLign).Activate

wss.Select
Range("B34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End Sub

Le 09/08/2013 à 11:25

Merci pour ta réponse.

  For k = LastLign To 15 Step -1

Première question, pourquoi avoir modifier la boucle ?

If lastlignmonth <> 0 Then Exit For
Next i

Si jamais je ne trouve pas la date dans la base, je sors de la boucle et je vais tester la date suivante qui est dans la feuille de synthèse. Néanmoins, je n'arrive pas à faire valider cette condition, il me dit "Next sans For"...

Peux tu m'expliquer cette partie du code :

        t = wsp.Cells(14, j).Address
        Critere= Mid(t, 2, InStr(2, t, "$") - 2)

Merci beaucoup.

Le 09/08/2013 à 13:45

Je ne trouve pas la solution ....

Merci de votre aide.

Le 09/08/2013 à 13:48

Bonjour,

Serait-il envisageable d'avoir le fichier afin de faire des tests?

Merci @+

Le 09/08/2013 à 13:53

yes ! J'étais justement en train d'en construire un.

La feuille critère 1 présente un exemple du résultat attendu.

12exemple.xlsx (12.59 Ko)

Le 09/08/2013 à 15:15

J'ai réussi à faire un code qui tourne mais le problème c'est que ça ne copie pas dans la bonne colonne cible.

Sub Selectionprojet()

  Dim DerLigne As Long
  Dim tri As String
  Dim FirstLign As String
  Dim wksSource As Worksheet
  Dim synthesesheet As Worksheet
  Dim KPI As String
  Dim LastMonth As Date
  Dim LastLign As Long
  Dim LastLignMonth As String
  Dim month As String
  Dim KPIColumn As String
  Dim i, j, k, l As Integer

Set synthesesheet = ActiveSheet
Set wksSource = Worksheets("Projects Data")
KPI = Range("A1").Value

For i = 8 To 50
Boucle:
i = i + 1
month = synthesesheet.Cells(33, i).Value

LastLign = wksSource.Range("A" & Rows.Count).End(xlUp).Row
LastMonth = wksSource.Range("A" & Rows.Count).End(xlUp).Value

    For k = LastLign To 15 Step -1
            If wksSource.Cells(k, 1) = month Then
            LastLignMonth = k
        Exit For
        End If
    Next k

If LastLignMonth = "" Then
GoTo Boucle
End If

    For l = 15 To LastLign
            If wksSource.Cells(l, 1) = month Then
            FirstLign = l
        Exit For
        End If
    Next l

    For j = 1 To 50
            If wksSource.Cells(14, j).Value = KPI Then
            t = wksSource.Cells(14, j).Address
            KPIColumn = Mid(t, 2, InStr(2, t, "$") - 2)
        Exit For
        End If
    Next j

wksSource.Range("B" & FirstLign & ":H" & LastLignMonth & "," & KPIColumn & FirstLign & ":" & KPIColumn & LastLignMonth).Copy

synthesesheet.Range("B34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Next i

End Sub

Le 09/08/2013 à 15:46

Voici la dernière version mais le code ne s’arrête pas !

Set synthesesheet = ActiveSheet
Set wksSource = Worksheets("Projects Data")
KPI = Range("A1").Value
a = 0

For i = 8 To 50
Boucle:
i = i + 1
month = synthesesheet.Cells(33, i).Value

LastLign = wksSource.Range("A" & Rows.Count).End(xlUp).Row
LastMonth = wksSource.Range("A" & Rows.Count).End(xlUp).Value

    For k = LastLign To 15 Step -1
            If wksSource.Cells(k, 1) = month Then
            LastLignMonth = k
        Exit For
        End If
    Next k

If LastLignMonth = "" Then
GoTo Boucle
End If

    For l = 15 To LastLign
            If wksSource.Cells(l, 1) = month Then
            FirstLign = l
        Exit For
        End If
    Next l

    For j = 1 To 50
            If wksSource.Cells(14, j).Value = KPI Then
            t = wksSource.Cells(14, j).Address
            KPIColumn = Mid(t, 2, InStr(2, t, "$") - 2)
        Exit For
        End If
    Next j

wksSource.Range("B" & FirstLign & ":H" & LastLignMonth).Copy

synthesesheet.Range("B34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

wksSource.Range(KPIColumn & FirstLign & ":" & KPIColumn & LastLignMonth).Copy

synthesesheet.Cells(34, i).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Next i

End Sub

Le 09/08/2013 à 16:19

Voilà où j'en suis. La boucle s'arrête bien mais problème :

Les valeurs que je copie dans la base de données pour le mois suivant ne sont pas collées à la bonne ligne !

Sub importer()

  Dim DerLigne As Long
  Dim tri As String
  Dim FirstLign As String
  Dim wksSource As Worksheet
  Dim synthesesheet As Worksheet
  Dim KPI As String
  Dim LastMonth As Date
  Dim LastLign As Long
  Dim LastLignMonth As String
  Dim month As String
  Dim KPIColumn As String
  Dim i, j, k, l As Integer

Set synthesesheet = ActiveSheet
Set wksSource = Worksheets("Projects Data")
KPI = Range("A1").Value

For i = 9 To 30

month = synthesesheet.Cells(33, i).Value

LastLign = wksSource.Range("A" & Rows.Count).End(xlUp).Row
LastMonth = wksSource.Range("A" & Rows.Count).End(xlUp).Value

    For k = LastLign To 15 Step -1
            If wksSource.Cells(k, 1) = month Then
            LastLignMonth = k
            Exit For
            Else
            GoTo Suite

        End If
    Next k

    For l = 15 To LastLign
            If wksSource.Cells(l, 1) = month Then
            FirstLign = l
        Exit For
        End If
    Next l

    For j = 1 To 50
            If wksSource.Cells(14, j).Value = KPI Then
            t = wksSource.Cells(14, j).Address
            KPIColumn = Mid(t, 2, InStr(2, t, "$") - 2)
        Exit For
        End If
    Next j

wksSource.Range("B" & FirstLign & ":H" & LastLignMonth).Copy

synthesesheet.Range("B34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

wksSource.Range(KPIColumn & FirstLign & ":" & KPIColumn & LastLignMonth).Copy

synthesesheet.Cells(34, i).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

LastLignMonth = ""

Suite:

Next i

End Sub

Le 09/08/2013 à 18:16

turz a écrit :
Merci pour ta réponse.
  For k = LastLign To 15 Step -1
Première question, pourquoi avoir modifier la boucle ?

pour avoir la dernière ligne avec le mois, on part de la fin et on remonte, dès qu'on a trouvé la ligne c'est la dernière, ton code sort de la boucle après avoir trouvé la première ligne.

turz a écrit :
If lastlignmonth <> 0 Then Exit For
Next i
Si jamais je ne trouve pas la date dans la base, je sors de la boucle et je vais tester la date suivante qui est dans la feuille de synthèse. Néanmoins, je n'arrive pas à faire valider cette condition, il me dit "Next sans For"...

c'est que tu as modifié le code que je t'ai envoyé. Parce ce que c'est bien cette logique que j'ai programmée et qui fonctionne (en tout cas chez moi).

turz a écrit :
Peux tu m'expliquer cette partie du code :
        t = wsp.Cells(14, j).Address
        Critere= Mid(t, 2, InStr(2, t, "$") - 2)

pour l'utilisation que tu vas en faire dans la suite, critère doit contenir non pas le numéro de la colonne mais son identifiant de colonne. A, B, C, ..AA, AB, et non 1,2,3,..27. la première instruction met l'adresse de la cellule sous la for $x$14 dans la variable t, l'instruction suivante extrait "x" de t et le met dans critère.

turz a écrit :
Merci beaucoup.

de rien

Le 09/08/2013 à 22:50

turz a écrit :

Voilà où j'en suis. La boucle s'arrête bien mais problème :

Les valeurs que je copie dans la base de données pour le mois suivant ne sont pas collées à la bonne ligne !

Sub importer()

  Dim DerLigne As Long
  Dim tri As String
  Dim FirstLign As String
  Dim wksSource As Worksheet
  Dim synthesesheet As Worksheet
  Dim KPI As String
  Dim LastMonth As Date
  Dim LastLign As Long
  Dim LastLignMonth As String
  Dim month As String
  Dim KPIColumn As String
  Dim i, j, k, l As Integer

Set synthesesheet = ActiveSheet
Set wksSource = Worksheets("Projects Data")
KPI = Range("A1").Value

For i = 9 To 30

month = synthesesheet.Cells(33, i).Value

LastLign = wksSource.Range("A" & Rows.Count).End(xlUp).Row
LastMonth = wksSource.Range("A" & Rows.Count).End(xlUp).Value

    For k = LastLign To 15 Step -1
            If wksSource.Cells(k, 1) = month Then
            LastLignMonth = k
            Exit For
            Else
            GoTo Suite

        End If
    Next k

    For l = 15 To LastLign
            If wksSource.Cells(l, 1) = month Then
            FirstLign = l
        Exit For
        End If
    Next l

    For j = 1 To 50
            If wksSource.Cells(14, j).Value = KPI Then
            t = wksSource.Cells(14, j).Address
            KPIColumn = Mid(t, 2, InStr(2, t, "$") - 2)
        Exit For
        End If
    Next j

wksSource.Range("B" & FirstLign & ":H" & LastLignMonth).Copy

synthesesheet.Range("B34").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

wksSource.Range(KPIColumn & FirstLign & ":" & KPIColumn & LastLignMonth).Copy

synthesesheet.Cells(34, i).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

LastLignMonth = ""

Suite:

Next i

End Sub

bonsoir,

je n'avais donc pas tout à fait compris ce que tu voulais faire. je te conseille de regarder du coté des tables pivots.

Le 10/08/2013 à 11:46

Si tu ne veux pas utiliser les tables pivots, voici le code adapté (qui tient compte de ta logique de copie des données) et qui fonctionne sur ton fichier exemple.

Si les contraintes concernant la copie, indiquées dans le commentaire ne sont pas respectées, il faut revoir la logique de copie (par exemple faire la copie sur base d'un identifiant unique du projet).

bonne chance !

Sub test()
Dim wss As Object, wsp As Object

Set wsp = Worksheets("Projects Data")
Set wss = ActiveSheet
KPI = Cells(1, 1)
If KPI = "" Then MsgBox "pas de critère trouvé sur la feuille " & wss.Name & " dans la cellule (1,1)": End
LastLign = wsp.Range("A" & wsp.Rows.Count).End(xlUp).Row
LastMonth = wsp.Range("A" & wsp.Rows.Count).End(xlUp).Value

For i = 9 To 50
lastlignmonth = 0
Mois = wss.Cells(11, i).Value
t = wss.Cells(11, i).Address
coldate = Mid(t, 2, InStr(2, t, "$") - 2)

'identification de la dernière ligne comprenant la même date que mois

    For k = LastLign To 10 Step -1
            If wsp.Cells(k, 1) = Mois Then
            lastlignmonth = k
        Exit For
        End If
    Next k

'Si date trouvée on lance la copie
If lastlignmonth <> 0 Then

'identification de la première ligne comprenant la même date que month

    For l = 10 To LastLign
        If wsp.Cells(l, 1) = Mois Then
        FirstLign = l
        Exit For
        End If
    Next l

'identification de la colonne comprenant le critère

    For j = 9 To 50
        If wsp.Cells(9, j).Value = KPI Then
        t = wsp.Cells(9, j).Address
        critere = Mid(t, 2, InStr(2, t, "$") - 2): ' critère contient l'identifiant de colonne sous forme de lettre(s)
       Exit For
        End If
    Next j

' les instructions suivantes font l'hypothèse que pour chaque mois on ait toujours le même nombre de lignes dans projects data
' et que les informations dans les colonnes B à H soient également identiques et dans la même séquence.

'copie le bloc B:H
wsp.Range("B" & FirstLign & ":H" & lastlignmonth).Copy

wss.Range("B12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

' copie la colonne critère
wsp.Range(critere & FirstLign & ":" & critere & lastlignmonth).Copy

' dans la colonne du mois sélectionné
wss.Range(coldate & "12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If
' on passe au mois suivant
Next i

End Sub

Rechercher des sujets similaires à "copies feuille boucles"