Copie de valeurs en fonction d'une matrice

babylonzoo · 3 Mai 2009

Bonjour au forum

Voila mon probleme : je possede des valeurs dans une premiere feuille nommée "MavtRe" avec des numeros d'individus ( ici de 1 a 70) et 2 valeurs pas individus ( L et l ) qui viennent s'incrementer ligne par ligne toute les semaines. J'aimerai pouvoir copier la derniere ligne de valeur ainsi que le numeros d'individus en fonction de la matrice presente dans la feuille "design". les individus sont repartis en groupe et chaque groupe possede une nouvelle feuille.
ci joint une fichier exemple
merci pour votre aide
babylonzoo

PMO2 · 4 Mai 2009

Re : Copie de valeurs en fonction d'une matrice

Bonjour,

Une piste en VBA. Je me suis entièrement basé sur votre exemple aussi les structures des plages devront être
les mêmes dans un nouveau projet. La macro construit une nouvelle feuille pour chaque groupe à partir d'une feuille
cachée "___template" qui sert de modèle (évitez donc de la supprimer par mégarde).
Cette feuille est à démasquer et à recopier à partir du classeur exemple ci-joint.

Copiez le code suivant dans un module Standard en ayant, au préalable et dans l'éventualité, adapté à votre usage
les constantes cernées par des ###

Code:

'### Constantes de nom de feuille (à adapter) ###
Const MAVTRE As String = "MavtRe"
Const DESIGN As String = "design"
'################################################
Const MODEL As String = "___template" 'modèle de feuille (cachée)

Sub FeuilleGroupe()
Dim S As Worksheet
Dim R As Range
Dim var1
Dim var2
Dim g&
Dim i&
Dim j&
Dim cpt&
Dim A$
Dim T()
On Error GoTo Erreur
Set S = Sheets(MODEL)
Set S = Sheets(MAVTRE)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[e65536].End(xlUp).Row, S.[iv4].End(xlToLeft).Column))
If R.Rows.Count < 5 Then Exit Sub
var1 = R
Set S = Sheets(DESIGN)
Set R = S.Range(S.Cells(7, 1), S.Cells(S.[a65536].End(xlUp).Row, 18))
If R.Rows.Count < 2 Then Exit Sub
var2 = R
Set S = Nothing
On Error Resume Next
For i& = 2 To UBound(var2, 1)
  Set S = Sheets(var2(i&, 2))
  If Not S Is Nothing Then
    A$ = A$ & Space(50) & var2(i&, 2) & vbCrLf
  End If
Next i&
If A$ <> "" Then
  A$ = "Veuillez supprimer ou renommer les feuilles suivantes qui existent déjà" & vbCrLf & vbCrLf & A$
  MsgBox A$
  Exit Sub
End If
On Error GoTo Erreur
For g& = 2 To UBound(var2, 1)
  Sheets(MODEL).Copy After:=Sheets(Sheets.Count)
  Set S = Sheets(Sheets.Count)
  S.Visible = xlSheetVisible
  S.Name = var2(g&, 2)
  S.[e1] = "GROUPE " & var2(g&, 1)
  cpt& = 1
  ReDim T(1 To 1, 1 To 20)
  For j& = 9 To 18
    T(1, cpt&) = var2(g&, j&)
    cpt& = cpt& + 2
  Next j&
  S.Range("e3:x3") = T
  For j& = 1 To 20 Step 2
    For i& = 5 To UBound(var1, 2) Step 2
      If var1(3, i&) = T(1, j&) Then
        S.Range(S.Cells(5, j& + 4), S.Cells(5, j& + 4)) = var1(UBound(var1, 1), i&)
        S.Range(S.Cells(5, j& + 5), S.Cells(5, j& + 5)) = var1(UBound(var1, 1), i& + 1)
      End If
    Next i&
  Next j&
  For j& = 1 To 4
    S.Range(S.Cells(5, j&), S.Cells(5, j&)) = var1(UBound(var1, 1), j&)
  Next j&
Next g&
Exit Sub
Erreur:
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub

Il n'y a plus qu'à faire tourner la Sub FeuilleGroupe.

Cordialement.

PMO
Patrick Morange

babylonzoo · 4 Mai 2009

Re : Copie de valeurs en fonction d'une matrice

Bonjour patrick,

un grand merci pour cette macro qui fonctionne parfaitement

.
je vais essayer de la decortiquer un peu pour la comprendre car mon niveau en VBA est loin d'etre aussi fort que le tien.
je reviendrai sans doute vers toi si j'ai besoin d'explications.
Encore merci
babylonzoo

babylonzoo · 8 Mai 2009

Re : Copie de valeurs en fonction d'une matrice

Bonjour patrick,
je reviens vers toi car j'ai essayé d'adapter un peu ta macro et je dois avouer que je n'arrive pas a faire exactement ce que je voudrais ( je n'arrive pas a bien comprendre comment modifier certains parametres de ta macro

).
je renvoi un fichier explicatif de mes demandes dans la fiche "design" en particulier comment ajouter de nouveau type de fiche avec des template differents.
si tu peux m'expliciter un peu ta macro car celle est hyper compacte donc nickel au niveau fonctionnement mais je suis un peu largué

merci encore
babylonzoo

PMO2 · 26 Mai 2009

Re : Copie de valeurs en fonction d'une matrice

Bonjour,

La nouvelle version prenant en compte les extensions que vous demandiez

Code:

'### Constantes de nom de feuille (à adapter) ###
Const MAVTRE As String = "MavtRe"
Const PAVTRE As String = "PavtRe"
Const DESIGN As String = "design"
'################################################
Const MODEL As String = "___template" 'modèle de feuille (cachée)
Const MODEL2 As String = "___template2" 'modèle de feuille (cachée)
Const MODEL3 As String = "___template3" 'modèle de feuille (cachée)

Sub FeuilleGroupe()
Dim Sactive As Worksheet
Dim S As Worksheet
Dim R As Range
Dim var1
Dim var2
Dim lastCol&
Dim g&
Dim i&
Dim j&
Dim cpt&
Dim A$
Dim T()
Set Sactive = ActiveSheet
    '################## MAVTRE ##################
Application.ScreenUpdating = False
On Error GoTo Erreur
Set S = Sheets(MODEL)
Set S = Sheets(MAVTRE)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[e65536].End(xlUp).Row, S.[iv4].End(xlToLeft).Column))
If R.Rows.Count < 5 Then Exit Sub
var1 = R
Set S = Sheets(DESIGN)
Set R = S.Range(S.Cells(7, 1), S.Cells(S.[a65536].End(xlUp).Row, S.UsedRange.Columns.Count))
If R.Rows.Count < 2 Then Exit Sub
var2 = R
On Error Resume Next
For i& = 2 To UBound(var2, 1)
  Set S = Nothing
  Set S = Sheets(var2(i&, 2))
  If Not S Is Nothing Then
    A$ = A$ & Space(50) & var2(i&, 2) & vbCrLf
  End If
Next i&
If A$ <> "" Then
  A$ = "Veuillez supprimer ou renommer les feuilles suivantes qui existent déjà" & vbCrLf & vbCrLf & A$
  MsgBox A$
  Exit Sub
End If
On Error GoTo Erreur
For g& = 2 To UBound(var2, 1)
  Sheets(MODEL).Copy After:=Sheets(Sheets.Count)
  Set S = Sheets(Sheets.Count)
  S.Visible = xlSheetVisible
  S.Name = var2(g&, 2)
  S.[e1] = "GROUPE " & var2(g&, 1)
  lastCol& = S.[iv4].End(xlToLeft).Column
  cpt& = 1
  ReDim T(1 To 1, 1 To UBound(var1, 2))
  For j& = 9 To UBound(var2, 2)
    T(1, cpt&) = var2(g&, j&)
    cpt& = cpt& + 2
  Next j&
  S.Range(S.Cells(3, 5), S.Cells(3, lastCol&)) = T
  For j& = 1 To UBound(T, 2) Step 2
    For i& = 5 To UBound(var1, 2) Step 2
      If var1(3, i&) = T(1, j&) Then
        S.Range(S.Cells(5, j& + 4), S.Cells(5, j& + 4)) = var1(UBound(var1, 1), i&)
        S.Range(S.Cells(5, j& + 5), S.Cells(5, j& + 5)) = var1(UBound(var1, 1), i& + 1)
      End If
    Next i&
  Next j&
  For j& = 1 To 4
    S.Range(S.Cells(5, j&), S.Cells(5, j&)) = var1(UBound(var1, 1), j&)
  Next j&
  With S.Range("e1")
    If .MergeCells Then .MergeArea.UnMerge
  End With
  cpt& = S.[iv3].End(xlToLeft).Column + 1
  For j& = lastCol& To cpt& + 1 Step -1
    S.Columns(j&).Delete
  Next j&
  Set R = S.Range(S.Cells(1, 5), S.Cells(2, cpt&))
  R.MergeCells = True
  For j& = 7 To 10
    With R.Borders(j&)
      .LineStyle = xlContinuous
      .Weight = xlThin
    End With
  Next j&
Next g&
    '################## PAVTRE ##################
Set S = Sheets(MODEL2)
Set S = Sheets(PAVTRE)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[e65536].End(xlUp).Row, S.[iv4].End(xlToLeft).Column))
If R.Rows.Count < 5 Then Exit Sub
var1 = R
On Error Resume Next
For i& = 2 To UBound(var2, 1)
  Set S = Nothing
  Set S = Sheets(var2(i&, 3))
  If Not S Is Nothing Then
    A$ = A$ & Space(50) & var2(i&, 3) & vbCrLf
  End If
Next i&
If A$ <> "" Then
  A$ = "Veuillez supprimer ou renommer les feuilles suivantes qui existent déjà" & vbCrLf & vbCrLf & A$
  MsgBox A$
  Exit Sub
End If
On Error GoTo Erreur
For g& = 2 To UBound(var2, 1)
  Sheets(MODEL2).Copy After:=Sheets(Sheets.Count)
  Set S = Sheets(Sheets.Count)
  S.Visible = xlSheetVisible
  S.Name = var2(g&, 3)
  S.[e1] = "GROUPE " & var2(g&, 1)
  lastCol& = S.[iv4].End(xlToLeft).Column
  cpt& = 1
  ReDim T(1 To 1, 1 To UBound(var1, 2))
  For j& = 9 To UBound(var2, 2)
    T(1, cpt&) = var2(g&, j&)
    cpt& = cpt& + 1
  Next j&
  S.Range(S.Cells(3, 5), S.Cells(3, lastCol&)) = T
  For j& = 1 To UBound(T, 2)
    For i& = 5 To UBound(var1, 2)
      If var1(3, i&) = T(1, j&) Then
        S.Range(S.Cells(5, j& + 4), S.Cells(5, j& + 4)) = var1(UBound(var1, 1), i&)
      End If
    Next i&
  Next j&
  For j& = 1 To 4
    S.Range(S.Cells(5, j&), S.Cells(5, j&)) = var1(UBound(var1, 1), j&)
  Next j&
  With S.Range("e1")
    If .MergeCells Then .MergeArea.UnMerge
  End With
  cpt& = S.[iv3].End(xlToLeft).Column
  For j& = lastCol& To cpt& + 1 Step -1
    S.Columns(j&).Delete
  Next j&
  Set R = S.Range(S.Cells(1, 5), S.Cells(2, cpt&))
  R.MergeCells = True
  For j& = 7 To 10
    With R.Borders(j&)
      .LineStyle = xlContinuous
      .Weight = xlThin
    End With
  Next j&
Next g&
    '################## Observations ##################
Set S = Sheets(MODEL3)
On Error Resume Next
For i& = 2 To UBound(var2, 1)
  Set S = Nothing
  Set S = Sheets(var2(i&, 4))
  If Not S Is Nothing Then
    A$ = A$ & Space(50) & var2(i&, 4) & vbCrLf
  End If
Next i&
If A$ <> "" Then
  A$ = "Veuillez supprimer ou renommer les feuilles suivantes qui existent déjà" & vbCrLf & vbCrLf & A$
  MsgBox A$
  Exit Sub
End If
On Error GoTo Erreur
For g& = 2 To UBound(var2, 1)
  Sheets(MODEL3).Copy After:=Sheets(Sheets.Count)
  Set S = Sheets(Sheets.Count)
  S.Visible = xlSheetVisible
  S.Name = var2(g&, 4)
  S.[f1] = "GROUPE " & var2(g&, 1)
  For j& = 9 To UBound(var2, 2)
    S.Range(S.Cells(4, j& - 3), S.Cells(4, j& - 3)) = var2(g&, j&)
  Next j&
  With S.Range("f1")
    If .MergeCells Then .MergeArea.UnMerge
  End With
  With S.Range("f3")
    If .MergeCells Then .MergeArea.UnMerge
  End With
  cpt& = S.[iv4].End(xlToLeft).Column
  For j& = lastCol& + 1 To cpt& + 1 Step -1
    S.Columns(j&).Delete
  Next j&
  Set R = S.Range(S.Cells(1, 6), S.Cells(2, cpt&))
  R.MergeCells = True
  For j& = 7 To 10
    With R.Borders(j&)
      .LineStyle = xlContinuous
      .Weight = xlThin
    End With
  Next j&
  Set R = S.Range(S.Cells(3, 6), S.Cells(3, cpt&))
  R.MergeCells = True
  For j& = 7 To 10
    With R.Borders(j&)
      .LineStyle = xlContinuous
      .Weight = xlThin
    End With
  Next j&
Next g&
Sactive.Activate
Application.ScreenUpdating = True
Exit Sub
Erreur:
Application.ScreenUpdating = True
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub

Cordialement.

PMO
Patrick Morange

babylonzoo · 30 Mai 2009

Re : Copie de valeurs en fonction d'une matrice

salut patrick ,

merci encore pour le fichier, je suis en vacances et je le testerai des mon retour,
merci encore
babylonzoo

babylonzoo · 19 Juin 2009

Re : Copie de valeurs en fonction d'une matrice

Salut patrick,

merci pour le travail effectué sur la matrice.
j'ai encore qqs petites modifs a effectuer et malgré mes essais je n'obtient pas le résultats escompté. tu trouveras dans le fichier joint les choses a modifier ( j'ai rajouté 2 templates et effectué qqs modifs mineures dans le code

j'ai enlevé les test que j'avais effectué et remis le code d'applomb

)
merci encore
je pourrais ensuite continuer à travailler sur la saisie des valeurs au sein des fiches ( j'ai deja bien commencé .d'ailleurs si tu as un tuyau pour que les valeurs saisie via text box dans un userform vienne se mettre sous la bonne identification : genre je saisie mon id, je rentre mes valeurs, je valide et la colonne ou se trouve l'id est reconnue et les valeurs se mettent ou bonne endroit).....mais bon c'est un autre histoire

babylonzoo

Effectuez une recherche sur Excel Downloads...

Copie de valeurs en fonction d'une matrice

babylonzoo

XLDnaute Nouveau

Pièces jointes

PMO2

XLDnaute Accro

babylonzoo

XLDnaute Nouveau

babylonzoo

XLDnaute Nouveau

Pièces jointes

PMO2

XLDnaute Accro

babylonzoo

XLDnaute Nouveau

babylonzoo

XLDnaute Nouveau

Pièces jointes

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums