Optimisation de macro

Le 21/01/2018 à 22:09

Bonjour à tous,

Dans un de mes fichiers excel, j'utilise cette macro:

Public Sub nb_videsAB()
Dim idd As Long, idr As Long, nbr As Long, tbd
    tbd = ActiveSheet.UsedRange.Columns("A").Cells.Value
ReDim tbr(1 To UBound(tbd))
    For idd = 1 To UBound(tbd)
        If tbd(idd, 1) <> "" Then
            If nbr <> 0 Then tbr(idr) = nbr: nbr = 1
            idr = idd
        ElseIf tbd(idd, 1) = "" Then
            nbr = nbr + 1
        End If
    Next idd
    Range("B1").Resize(UBound(tbr), 1).Value = Application.Transpose(tbr)
End Sub

Public Sub nb_videsCD()
Dim idd As Long, idr As Long, nbr As Long, tbd
    tbd = ActiveSheet.UsedRange.Columns("C").Cells.Value
ReDim tbr(1 To UBound(tbd))
    For idd = 1 To UBound(tbd)
        If tbd(idd, 1) <> "" Then
            If nbr <> 0 Then tbr(idr) = nbr: nbr = 1
            idr = idd
        ElseIf tbd(idd, 1) = "" Then
            nbr = nbr + 1
        End If
    Next idd
    Range("D1").Resize(UBound(tbr), 1).Value = Application.Transpose(tbr)
End Sub

Public Sub nb_videsEF()
Dim idd As Long, idr As Long, nbr As Long, tbd
    tbd = ActiveSheet.UsedRange.Columns("E").Cells.Value
ReDim tbr(1 To UBound(tbd))
    For idd = 1 To UBound(tbd)
        If tbd(idd, 1) <> "" Then
            If nbr <> 0 Then tbr(idr) = nbr: nbr = 1
            idr = idd
        ElseIf tbd(idd, 1) = "" Then
            nbr = nbr + 1
        End If
    Next idd
    Range("F1").Resize(UBound(tbr), 1).Value = Application.Transpose(tbr)
End Sub

Sub VideAtoE()
Call nb_videsAB
Call nb_videsCD
Call nb_videsEF
End Sub

Si l'on prend la 1ère macro (Public Sub nb_videsAB) et la 2ème macro (Public Sub nb_videsCD), seules deux lignes changent: ActiveSheet.UsedRange.Columns("A").Cells.Value devient ActiveSheet.UsedRange.Columns("C").Cells.Value

et Range("B1").Resize(UBound(tbr), 1).Value = Application.Transpose(tbr) devient Range("D1").Resize(UBound(tbr), 1).Value = Application.Transpose(tbr)

Les colonnes vont toujours par deux, la 1ère macro c'est A et B, la 2ème C et D, la 3ème E et F, la 4ème sera G et H etc...

N'y a-t-il pas un moyen de créer une seule et même macro au lieu des trois que j'ai actuellement ?

Car à l'avenir, j'aurai 300 colonnes différentes, soit potentiellement 150 macros !

Merci beaucoup pour votre aide !

Quik

Le 21/01/2018 à 22:40

Bonsoir,

une proposition de code non testé :

Public Sub nb_vides(Num_Col)
Dim idd As Long, idr As Long, nbr As Long, tbd
    tbd = ActiveSheet.UsedRange.Columns(Num_Col).Cells.Value
ReDim tbr(1 To UBound(tbd))
    For idd = 1 To UBound(tbd)
        If tbd(idd, 1) <> "" Then
            If nbr <> 0 Then tbr(idr) = nbr: nbr = 1
            idr = idd
        ElseIf tbd(idd, 1) = "" Then
            nbr = nbr + 1
        End If
    Next idd
    ' ci dessous je n'ai pas testé, à voir si cela marche...
    Cells(1, Num_Col + 1).Resize(UBound(tbr), 1).Value = Application.Transpose(tbr)
End Sub

Sub VideAtoE()
    For i = 1 To 3 ' reste à mettre en variable la valeur trois
    ' comme par exemple trouver le nombre de la dernière colonne utilisée
    ' puis la diviser par deux
        Call nb_vides((i * 2) - 1)
    Next i
End Sub

L'idée :

une boucle qui lance plusieurs fois le même code mais avec un paramètre dépendant de la valeur de la variable de la boucle, cette valeur calculée correspond au numéro de la première colonne de référence pour le code.

Dans la première ligne d'instruction c'est le numéro "envoyé" qui est utilisé, pour la seconde ligne c'est le numéro de colonne +1

Pas tester, mais l'idée est là...

@ bientôt

LouReeD

Le 22/01/2018 à 08:41

Bonjour,

Bonjour LouReed,

Un exemple pour le principe (boucle toutes les 2 colonnes).

Je n'ai pas tout compris du fonctionnement (l'objectif) des macros!...

Cdlt.

1quik09.xlsm (25.15 Ko)
Public Sub TEST()
Dim tbl, Arr()
Dim lrow As Long, lCol As Long, k As Long
    With ActiveSheet
        tbl = .UsedRange.Value
        For lCol = LBound(tbl, 2) To UBound(tbl, 2) Step 2
            k = 0
            For lrow = LBound(tbl) To UBound(tbl)
                If tbl(lrow, lCol) <> "" Then
                    ReDim Preserve Arr(1, k + 1)
                    Arr(0, k) = tbl(lrow, lCol)
                    k = k + 1
                End If
            Next lrow
            .Cells(1, lCol).Offset(, 1).Resize(UBound(Arr, 2), 1).Value = Application.Transpose(Arr)
            Erase Arr
        Next lCol
    End With
End Sub
Le 22/01/2018 à 22:41

Bonjour LouReeD et Jean-Eric,

Merci pour vos réponses !

LouReed ta solution fonctionne parfaitement, il y a juste le fait que la 1ère doivent être pleine. Est-t-il possible que ta macro commence à fonctionner uniquement dès la 2ème ligne ?

Jean-Eric, une erreur s'affiche lorsque je lance la macro. Je te joint mon fichier :

10nb-case-vide-22-01-18.xlsm (180.62 Ko)

Merci à vous deux !

Quik

Le 22/01/2018 à 23:21

Bonsoir,

je viens de tester vos "anciens" codes sur les trois premières paires de colonne, et mon code, sur ces colonnes les résultats sont identiques...

Donc le soucis que vous indiquez vient de votre code, de mon coté je n'ai mis en place que l'option "variable" de votre code.

Excusez moi de pas comprendre votre demande...

@ bientôt

LouReeD

Le 23/01/2018 à 01:26

Re,

Oui exactement mais étant pas du tout expert en macro, je vous pose la question à vous pour savoir si vous voyez une solution

Cette macro je l'ai prise de quelqu'un, elle n'est pas de moi et malheureusement je ne la comprend pas totalement !

Merci

Le 23/01/2018 à 09:03

Bonjour,

Ta macro revisitée qui boucle toutes les 2 colonnes...

Toujours pas compris l'objectif.

Cdlt.

Public Sub TEST()
Dim tbd, tbr()
Dim idd As Long, lCol As Long, idr As Long, nbr As Long
    With ActiveSheet
        tbd = .UsedRange.Value
        For lCol = LBound(tbd, 2) To UBound(tbd, 2) Step 2
            ReDim tbr(1 To UBound(tbd))
            For idd = LBound(tbd) To UBound(tbd)
                If tbd(idd, lCol) <> "" Then
                    If nbr <> 0 Then tbr(idr) = nbr: nbr = 1
                    idr = idd
                ElseIf tbd(idd, lCol) = "" Then
                    nbr = nbr + 1
                End If
            Next idd
            .Cells(1, lCol).Offset(, 1).Resize(UBound(tbr, 1), 1).Value = Application.Transpose(tbr)
            Erase tbr
        Next lCol
    End With
End Sub
Le 23/01/2018 à 09:34

Bonjour,

un peu comme Jean-Eric, mais cette fois ci avec le code ci dessous cela devrait correspondre à ce que vous cherchez à faire :

Public Sub nb_vides(Num_Col)
Dim idd As Long, idr As Long, nbr As Long, tbd
    tbd = ActiveSheet.UsedRange.Columns(Num_Col).Cells.Value
    ' ici ajout de la valeur "de départ" de la variable idr
    idr = 1
ReDim tbr(1 To UBound(tbd))
    For idd = 1 To UBound(tbd)
        If tbd(idd, 1) <> "" Then
            If nbr <> 0 Then
                tbr(idr) = nbr
            Else
                nbr = 1
                ' mise "en mémoire" de la première valeur de la première colonne...
                tbr(idr) = nbr
            End If
            idr = idd
        ElseIf tbd(idd, 1) = "" Then
            nbr = nbr + 1
        End If
    Next idd
    ' ci dessous je n'ai pas testé, à voir si cela marche...
    Cells(1, Num_Col + 1).Resize(UBound(tbr), 1).Value = Application.Transpose(tbr)
End Sub

Sub VideAtoE()
    For i = 1 To 15 ' reste à mettre en variable la valeur trois
    ' comme par exemple trouver le nombre de la dernière colonne utilisée
    ' puis la diviser par deux
        Call nb_vides((i * 2) - 1)
    Next i
End Sub

En fait s'il y avait deux valeurs concécutives sur les deux premières lignes d'une colonne, votre code ignorait la valeur de la première ligne.

J'ai ajouté une définition de valeur de la variable idr à 1 en début de code et mis en mémoire dans le tableau la valeur "1" si le cas se trouvait, c'est à dire nbr=0 donc nbr = 1 et tbr(idr) = nbr où idr=1 à la première boucle grace à sa définition à 1 avant la boucle...

Bref ça à l'air de fonctionner.

@ bientôt

LouReeD

Le 23/01/2018 à 21:27

Merci beaucoup à vous deux, c'est tout bon !

Le 23/01/2018 à 23:15

Bonsoir,

merci @ vous !

@ bientôt

LouReeD

Rechercher des sujets similaires à "optimisation macro"