Etirer une cellule avec une macro

Bonjour, j’espère avoir une réponse de votre part, car je ne trouve pas la réponse.

j'ai exposer mon probleme dans le fichier excel que j'ai joint.

J’espère que je suis clair dans ma problématique, sinon demander moi.

Merci

Bonjour,

Une piste, résultat en colonnes de A à F à partir de la ligne 1 :

Sub Test()

    Dim Tbl
    Dim I As Integer
    Dim J As Integer

    Tbl = Array("RO", 1, 2, 3)

    'en colonnes A à D
    For I = 0 To UBound(Tbl)

        Cells(1, I + 1).Value = Tbl(I)
        Cells(1, I + 1).AutoFill Range(Cells(1, I + 1), Cells(99, I + 1)), 1

    Next I

    J = Tbl(UBound(Tbl))

    'en colonne E et F
    For I = 1 To 99 Step 12

        J = J + 1
        Cells(I, 5).Value = J
        Cells(I, 5).AutoFill Range(Cells(I, 5), Cells(I + IIf(I = 97, 2, 11), 5)), 1

        Cells(I, 6).Value = 1
        Cells(I, 6).AutoFill Range(Cells(I, 6), Cells(I + IIf(I = 97, 2, 11), 6)), 9

    Next I

End Sub

Bonjour Tizi,

Si j'ai bien compris ton pb, je te propose :

Option Explicit

Sub Main_Process()

Const cColFirst = 30 ' A adapter suivant l'endroit où l'on veut le résultat

Const cNbIterations = 99

Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer

Dim lColori As Long, lColorj As Long, lColork As Long, lColorl As Long, lColorm As Long

Dim lRow As Long

Dim oRange As Excel.Range

Dim oSheet As Excel.Worksheet

i = 1

j = 2

k = 3

l = 4

m = 1

Set oSheet = ThisWorkbook.Worksheets(1)

Set oRange = oSheet.Cells(1, 2)

lColori = oRange.Interior.Color

Set oRange = oSheet.Cells(1, 3)

lColorj = oRange.Interior.Color

Set oRange = oSheet.Cells(1, 4)

lColork = oRange.Interior.Color

Set oRange = oSheet.Cells(1, 5)

lColorl = oRange.Interior.Color

Set oRange = oSheet.Cells(1, 6)

lColorm = oRange.Interior.Color

Do Until i > cNbIterations

Do Until j > cNbIterations

Do Until k > cNbIterations

Do Until l > cNbIterations

For m = 1 To 12

lRow = lRow + 1

Set oRange = oSheet.Cells(lRow, cColFirst)

oRange.Value = "RO"

Set oRange = oSheet.Cells(lRow, cColFirst + 1)

oRange.Value = Min(i, cNbIterations)

oRange.Interior.Color = lColori

Set oRange = oSheet.Cells(lRow, cColFirst + 2)

oRange.Value = Min(j, cNbIterations)

oRange.Interior.Color = lColorj

Set oRange = oSheet.Cells(lRow, cColFirst + 3)

oRange.Value = Min(k, cNbIterations)

oRange.Interior.Color = lColork

Set oRange = oSheet.Cells(lRow, cColFirst + 4)

oRange.Value = Min(l, cNbIterations)

oRange.Interior.Color = lColorl

Set oRange = oSheet.Cells(lRow, cColFirst + 5)

oRange.Value = m

oRange.Interior.Color = lColorm

Next

l = l + 1

Loop

l = cNbIterations

k = k + 1

Loop

k = cNbIterations

j = j + 1

Loop

j = cNbIterations

i = i + 1

Loop

Set oRange = Nothing

Set oSheet = Nothing

End Sub

Function Min(zi As Integer, zMax As Integer) As Integer

If zi < zMax Then

Min = zi

Else

Min = zMax

End If

End Function

Bien cordialement,

GVS