Etirer une cellule avec une macro

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Répondre
t
tizi02p
Jeune membre
Jeune membre
Messages : 19
Inscrit le : 28 novembre 2017
Version d'Excel : 2016

Message par tizi02p » 28 novembre 2017, 15:04

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
essais.xlsx
(9.73 Kio) Téléchargé 18 fois
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'019
Appréciations reçues : 306
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 28 novembre 2017, 16:03

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
Il vaut mieux un qui sait que cent qui cherchent :wink:

Ce forum étant un lieu de partage, je n'accepte pas les messages privés !
Avatar du membre
GVIALLES
Membre dévoué
Membre dévoué
Messages : 825
Appréciations reçues : 74
Inscrit le : 28 novembre 2017
Version d'Excel : 2016, 360
Téléchargements : Mes applications

Message par GVIALLES » 28 novembre 2017, 17:15

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
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message