Discussion :

[neo2k2]

Bonjour à tous.

Voila quelques années que je n'ai plus fait de VBA et j'ai une macro à créer pour mon job.

J'ai un tableau 3:n (col:row), contenant les infos suivantes :

Col1 Col2 Col3
Ligne1 proj1 essai nombre1
Ligne2 proj2 essai nombre2
...
LigneN projN essai nombreN

projN = nom d'un projet
essaiN = nom de l'essai
nombreN = nombre d'essais

Je veux que pour chaque Ligne, je crée une boucle FOR en fonction du nombre d'essais et je concatène le résultat sur une nouvelle feuille existante en collant :

Col1
Ligne1 proj1/essai-1
Ligne2 proj1/essai-2
...
LigneNombre1 proj1/essai-Nombre1
LigneSuivante proj2/essai-1
...
LigneSuivante+Nombre2 proj2/essai-Nombre2
...
LigneN projN/essai-1
LigneN+NombreN projN/essai-NombreN

Je vous présente mon code actuel qui effectue le copier-coller-concaténer pour la première ligne (et les suivante) mais ne permet pas de créer pour chaque ligne de la feuille1 plusieurs lignes sur la feuille 2.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Sub Macro1()
  '
  ' Déclaration des variables
  '
  Dim Num As Integer
  Dim NbRow As Integer
  Dim Label As String
  Dim Proj As String
  Dim Element As String
  Dim NewLabel As String
  Dim i As Integer
  '
  ' Sélectionner les cellules adjacentes à la sélections si elle ne sont pas vides
  '
  Sheets("Sheet1").Select
  '
  ' Compter le nombre de lignes à copier et chercher le nombre d'éléments
  '
  Num = Range("C3").End(xlUp).Value
  NbRow = ActiveCell.CurrentRegion.Rows.Count
  '
  ' Attribue les valeurs aux variables
  '
  Label = Range("A1").Value
  Proj = Range("B1").Value
  Element = Num
  NewLabel = Label & "/" & Proj & "-" & Num
  '
  ' Sélectionner les cellules adjacentes à la sélections si elle ne sont pas vides
  '
  Range("A1").Select
  '
  ' Copier les cellules sélectionnées
  '
  ActiveCell.CurrentRegion.Copy
  '
  ' Coller les cellules sur la deuxième feuille
  '
  Sheets("Sheet2").Select
  Range("A1").Select
  '
  ' [DEBUG]Afficher le résultat dans une MsgBox
  '
  MsgBox NewLabel
  '
  ' Coller le résultat en lignes tant que le nombre n'est pas atteint
  ' A CREER !!!
  '
  ActiveCell.PasteSpecial (xlPasteAll)
  Sheets("Sheet2").Range("A1").Value = NewLabel
  Sheets("Sheet2").Range("B1:C1").Value = ""
  '
  '
  '
End Sub

Merci d'avance pour votre aide...

P.S. je travaille sur Excel 2000 EN-US

[ouskel'n'or]

Bonjour (tardif) neo2k2, bienvenue sur le forum.
Je ne vais pas utiliser ton code pour te donner un exemple, tu essaieras de le comprendre pour l'adapter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Dim FL1 as worksheet
Dim FL2 as worksheet
Dim i as long, NoLigne as long, NoCol as byte, DerniereLigne as long
    Set FL1 = Worksheets("Sheet1")
    Set FL2 = Worksheets("Sheet2")
    DerniereLigne = FL1.Range("A65535").End(xlUp).Row
    For i = 1 to derniereLigne
         For NoCol = 1 to 3
              NoLigne = NoLigne+1
              FL2.Cells(NoLigne, 1) = FL1.Cells(i,NoCol)
         Next
    Next
    Set FL1 = NoThing
    Set FL2 = Nothing

Tu dis
A+

[neo2k2]

Merci pour ta réponse...

J'ai complété ce dont j'avais besoin... Je poste ici le code pour le cas où ça pourrait aider quelqu'un dans mon cas (il doit pas y en avoir beaucoup mais bon).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub CPM()
'
' CPM Macro
' Macro recorded 29.06.2007
' Description : CCPM is a macro to copy-paste and merge cell values.
'
Dim FL1 As Worksheet
Dim FL2 As Worksheet
Dim i, j As Long, NoLigne As Long, NoCol As Byte, DerniereLigne As Long
Dim Num, Content As String
 
Set FL1 = Worksheets("Sheet1")
Set FL2 = Worksheets("Sheet2")
 
DerniereLigne = FL1.Range("A65535").End(xlUp).Row
  For i = 1 To DerniereLigne
      Num = FL1.Cells(i, 3).Value
           For j = 1 To Num
              NoLigne = NoLigne + 1
            For NoCol = 1 To 3
                  Content = FL1.Cells(i, 1) & "-" & FL1.Cells(i, 2)
                  FL2.Cells(NoLigne, 1) = Content
              Next
          Next
  Next
 
Set FL1 = Nothing
Set FL2 = Nothing
'
End Sub

Encore merci pour ton aide.