Mise a jour code

Le 06/04/2022 à 23:05

Bonjour a tous.

Je me permets de solliciter votre aide car le code suivant que j'utilise pour extraire des donnees numerique sur une autre feuille fonctionné tres bien mais depuis des modifications sur les donnees a extraire je ne 'ai pas toutes la totalités.

avant ces donnees numerique etait composes de 12 chiffres mais depuis que d'autres sont a 11 chiffres desormais ceux ne sont pas pris en compte.

j'espere avoir été precis et je vous remercie de votre aide ( pour info ce code a été crée par Curulis57)

Private Sub CommandButton21_Click()

Dim sWk As Worksheet
Set sWk = Worksheets("Extract")
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'

    sWk.UsedRange.ClearContents
    On Error Resume Next
    '
    iRowA = Range("A:A").Find(what:="TOTAL OVER", lookat:=xlWhole, searchdirection:=xlPrevious).Row     'TOTAL OVER
    iRowAA = Range("A:A").Find(what:="OVERAGE RE", lookat:=xlWhole, searchdirection:=xlPrevious).Row    'OVERAGE RE
    iRowD = Range("D:D").Find(what:="MPLOYEE", lookat:=xlPart, searchdirection:=xlPrevious).Row         'MPLOYEE
    '
    Do While iOK = 0
        iOK = 1
        If iRowD1 < iRowD Then
            iOK = 0
            iOK1 = 0
            iCol = iCol + 1 ' ˆ partir de la colonne A
            sCol2 = Split(Columns(iCol).Address(ColumnAbsolute:=False), ":")(1)
            iRowD1 = Range("D" & iRowD1 + 1 & ":D" & iRowD).Find(what:="MPLOYEE", lookat:=xlPart, searchdirection:=xlNext).Row + 1
            iRowA1 = Range("A" & iRowD1 & ":A" & iRowA).Find(what:="TOTAL OVER", lookat:=xlWhole, searchdirection:=xlNext).Row
            iRowAA1 = Range("A" & iRowD1 & ":A" & iRowA1).Find(what:="OVERAGE", lookat:=xlPart, searchdirection:=xlPrevious).Row
            sData = Right(Cells(iRowD1, 4), Len(Cells(iRowD1, 4)) - 2)
            sWk.Cells(2, iCol) = sData
            sWk.Cells(3, iCol) = Cells(iRowD1, 5)
            Do While iOK1 = 0
                iOK1 = 1
                If iRowAA2 < iRowAA1 Then
                    iOK1 = 0
                    iRowAA2 = Range("A" & IIf(iRowAA2 = 0, iRowD1, iRowAA2 + 1) & ":A" & iRowAA1).Find(what:="OVERAGE", lookat:=xlPart, searchdirection:=xlNext).Row
                    iRowAA3 = Range("A" & iRowAA2 + 1 & ":A" & iRowA1).Find(what:="RUN TIME", lookat:=xlPart, searchdirection:=xlNext).Row
                    iCol1 = Cells(iRowAA2 + 2, Columns.Count).End(xlToLeft).Column
                    For x = 2 To iCol1 Step 2
                        sCol1 = Split(Columns(x).Address(ColumnAbsolute:=False), ":")(1)
                        If Cells(iRowAA2 + 3, x) <> "" Then
                            For y = iRowAA3 To iRowAA2 + 3 Step -1
                                If Cells(y, x) <> "" And Len(Cells(y, x)) = 14 And IsNumeric(Left(Cells(y, x), 1)) And IsNumeric(Right(Cells(y, x), 1)) Then

                                    iRow1 = y
                                    Exit For
                                End If
                            Next
                            iRow2 = sWk.Range(sCol2 & Rows.Count).End(xlUp).Row + 1
                            sWk.Range(sCol2 & iRow2).Resize(iRow1 - (iRowAA2 + 2), 1).Value = Range(sCol1 & iRowAA2 + 3 & ":" & sCol1 & iRow1).Value
                        End If
                    Next
                End If
                iRowAA2 = iRowAA3
            Loop
            iRowAA2 = 0
        End If
    Loop
    With sWk
        For x = 1 To iCol
            sCol = Split(.Columns(x).Address(ColumnAbsolute:=False), ":")(1)
            iRow = .Range(sCol & Rows.Count).End(xlUp).Row
            For y = iRow To 4 Step -1
                If .Cells(y, x) = "" Then .Cells(y, x).Delete shift:=xlUp
            Next
            .Columns(sCol & ":" & sCol).ColumnWidth = 15
        Next
        .Activate
          ActiveWindow.Zoom = 90
          Cells.EntireColumn.AutoFit
    End With
    On Error GoTo 0

'
Application.EnableEvents = True
Application.ScreenUpdating = True
Le 07/04/2022 à 00:31

Salut,

Sans fichier c'est pas évident, mais je vois un endroit ou tu as un test de longueur, tu dois peut-être regarder par là...

If Cells(y, x) <> "" And Len(Cells(y, x)) = 14 And IsNumeric(Left(Cells(y, x), 1)) And IsNumeric(Right(Cells(y, x), 1)) Then
Le 07/04/2022 à 01:01

Salut Kamellias,
Salut Jean-Paul,

déjà 4 ans, ce fichier! Que le temps passe!
Bien vu, Jean-Paul mais, heureusement que j'ai retrouvé le fichier, sans quoi, ce simple test n'aurait pas été suffisant!

Essaye ceci, Kamellias.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim sWk As Worksheet
Set sWk = Worksheets("Extract")
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("A1")) Is Nothing Then
    Cancel = True
    sWk.UsedRange.ClearContents
    On Error Resume Next
    '
    iRowA = Range("A:A").Find(what:="TOTAL OVER", lookat:=xlWhole, searchdirection:=xlPrevious).Row     'TOTAL OVER
    iRowAA = Range("A:A").Find(what:="OVERAGE RE", lookat:=xlWhole, searchdirection:=xlPrevious).Row    'OVERAGE RE
    iRowD = Range("D:D").Find(what:="MPLOYEE", lookat:=xlPart, searchdirection:=xlPrevious).Row         'MPLOYEE
    '
    Do While iOK = 0
        iOK = 1
        If iRowD1 < iRowD Then
            iOK = 0
            iOK1 = 0
            iCol = iCol + 1 ' ˆ partir de la colonne A
            sCol2 = Split(Columns(iCol).Address(ColumnAbsolute:=False), ":")(1)
            iRowD1 = Range("D" & iRowD1 + 1 & ":D" & iRowD).Find(what:="MPLOYEE", lookat:=xlPart, searchdirection:=xlNext).Row + 1
            iRowA1 = Range("A" & iRowD1 & ":A" & iRowA).Find(what:="TOTAL OVER", lookat:=xlWhole, searchdirection:=xlNext).Row
            iRowAA1 = Range("A" & iRowD1 & ":A" & iRowA1).Find(what:="OVERAGE", lookat:=xlPart, searchdirection:=xlPrevious).Row
            sData = Right(Cells(iRowD1, 4), Len(Cells(iRowD1, 4)) - 2)
            sWk.Cells(4, iCol) = sData
            sWk.Cells(1, iCol) = Cells(iRowD1, 5)
            Do While iOK1 = 0
                iOK1 = 1
                If iRowAA2 < iRowAA1 Then
                    iOK1 = 0
                    iRowAA2 = Range("A" & IIf(iRowAA2 = 0, iRowD1, iRowAA2 + 1) & ":A" & iRowAA1).Find(what:="OVERAGE", lookat:=xlPart, searchdirection:=xlNext).Row
                    iRowAA3 = Range("A" & iRowAA2 + 1 & ":A" & iRowA1).Find(what:="RUN TIME", lookat:=xlPart, searchdirection:=xlNext).Row - 2
                    iCol1 = Cells(iRowAA2 + 2, Columns.Count).End(xlToLeft).Column
                    For x = 2 To iCol1 Step 2
                        sCol1 = Split(Columns(x).Address(ColumnAbsolute:=False), ":")(1)
                        If Cells(iRowAA2 + 3, x) <> "" Then
                            For y = iRowAA3 To iRowAA2 + 3 Step -1
                                If Cells(y, x) <> "" And Len(Cells(y, x)) > 10 And IsNumeric(Left(Cells(y, x), 1)) And IsNumeric(Right(Cells(y, x), 1)) Then
                                    iRow1 = y
                                    Exit For
                                End If
                            Next
                            iRow2 = sWk.Range(sCol2 & Rows.Count).End(xlUp).Row + 1
                            sWk.Range(sCol2 & iRow2).Resize(iRow1 - (iRowAA2 + 2), 1).Value = Range(sCol1 & iRowAA2 + 3 & ":" & sCol1 & iRow1).Value
                        End If
                    Next
                End If
                iRowAA2 = iRowAA3
            Loop
            iRowAA2 = 0
        End If
    Loop
    With sWk
        For x = 1 To iCol
            sCol = Split(.Columns(x).Address(ColumnAbsolute:=False), ":")(1)
            iRow = .Range(sCol & Rows.Count).End(xlUp).Row
            For y = iRow To 4 Step -1
                If .Cells(y, x) = "" Then .Cells(y, x).Delete shift:=xlUp
            Next
            .Columns(sCol & ":" & sCol).ColumnWidth = 15
        Next
        .Activate
    End With
    On Error GoTo 0
End If
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End Sub
6kamellias-v2.xlsm (61.96 Ko)


A+

Le 07/04/2022 à 01:02

Bonsoir J. paul

Merci beaucoup.

effectivement je viens juste modifier la ligne de code en question et desormais tout fonctionne.

encore un grand merci

Le 07/04/2022 à 09:39

Salut @curulis57,

Juste pour information personnelle n'ayant pas le fichier sous la main, Pourquoi modifier :

iRowAA3 = Range("A" & iRowAA2 + 1 & ":A" & iRowA1).Find(what:="RUN TIME", lookat:=xlPart, searchdirection:=xlNext).Row - 2 et If Not Intersect(Target, Range("A1")) Is Nothing Then

As-tu vu quelque chose de plus qui n'était pas conforme ?

Le 07/04/2022 à 10:52

Salut Kamellias,
Salut Jean-Paul,

tu as l'oeil bien ouvert, dis donc!
- la ligne "IF" peut franchement être éliminée puisqu'elle limite le démarrage de la macro à un double-clic sur la seule cellule [A1] ce qui n'est pas nécessaire.
À "l'époque" (4 ans), je faisais ainsi ou je plaçais cette commande sur un contrôle 'Bouton de commande'.
- pour le calcul de iRowAA3, la cellule juste supérieure à "RUN TIME" dans la boucle est une date.
Comme le test de longueur passe de = 14 à > 10, cela créait un problème donc je zappe le problème en commençant la boucle au-delà de cette date.


A+

Rechercher des sujets similaires à "mise jour code"