Discussion :

[phipou55]

Bonjour
J'ai adapté une macro pour une nouvelle utilisation. Cette macro consiste à partir d'une liste de numéros ayant chacun un créneau horaire, d'établir des listes pour chaque créneau. Cette macro fonctionne mais je n'arriva pas à copier le numéro avec son format, sa couleur de cellule. je ne copie que la valeur. Est-ce que quelqu'un peur m'aider. D'avance merci. ci-dessous la macro

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
Sub compiler()
Dim i As Integer
Range("compteur").Value = 2
Sheets("Liste").Select
Range("B3:W38").Select
    Selection.ClearContents
   Range("A2").Select
Sheets("Bénéficiaires").Select
For Each cel In Range("cren")
    If IsNumeric(cel.Value) Then
        If cel.Value >= 1 Then
            i = cel.Value
            Sheets("Liste").Cells(1, i + 1).Value = Sheets("Liste").Cells(1, i + 1).Value + 1
            j = Sheets("Liste").Cells(1, i + 1).Value
            Sheets("Liste").Cells(j, i + 1).Value = Cells(cel.Row, 1).Value
        End If
    End If
Next
End Sub

[Menhir]

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
Sub compiler()
Dim i As Integer
 
Range("compteur").Value = 2
Sheets("Liste").Range("B3:W38").ClearContents
 
For Each cel In Sheets("Bénéficiaires").Range("cren")
    If IsNumeric(cel.Value) Then
        If cel.Value >= 1 Then
            i = cel.Value + 1
            Sheets("Liste").Cells(1, i).Value = Sheets("Liste").Cells(1, i).Value + 1
            j = Sheets("Liste").Cells(1, i).Value
            Sheets("Bénéficiaires").Cells(cel.Row, 1).Copy Sheets("Liste").Cells(j, i)
        End If
    End If
Next
End Sub

Je n'ai pas testé. Il y aura donc peut-être du débugage à faire.

[phipou55]

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
Sub compiler()
Dim i As Integer
 
Range("compteur").Value = 2
Sheets("Liste").Range("B3:W38").ClearContents
 
For Each cel In Sheets("Bénéficiaires").Range("cren")
    If IsNumeric(cel.Value) Then
        If cel.Value >= 1 Then
            i = cel.Value + 1
            Sheets("Liste").Cells(1, i).Value = Sheets("Liste").Cells(1, i).Value + 1
            j = Sheets("Liste").Cells(1, i).Value
            Sheets("Bénéficiaires").Cells(cel.Row, 1).Copy Sheets("Liste").Cells(j, i)
        End If
    End If
Next
End Sub

Je n'ai pas testé. Il y aura donc peut-être du débugage à faire.