Extraire et transposer

Le 19/12/2017 à 03:16

Bonsoir a Tous

Dans le fichier joint j'ai une feuille une macro sur laquelle j'ai importer plusieurs fichier texte dans la Feuil1( "DATA") a la suite

ce que je souhaiterai faire c'est pour chaque fichier TXT extraire en feuille 2 ("Resultat souhaite") voir dans l'exemple je vous ai fait le resultat a obtenir pour le premier fichier du classeur joint

pour cela j'ai mis tout ca en gras de couleurs rouge et faire cela pour tous les fichiers dans cette feuille."Data" et bien sure le nombre de fichier peut varier ainsi que les donnees pour chaque fichier txt.

Voir le classeur c'est plus Clair

19feuil5.xlsm (49.31 Ko)

je vous remercie de votre aide

Le 20/12/2017 à 02:02

Salut Kamellias,

voici ta macro avec démarrage via un double-clic en 'Data' [A1].

Dans ce genre d'exercice, tout repose sur la "stabilité" et la "régularité" de la "structure" des extractions.

A tester avec d'autres extractions du même type, donc.

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
            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 RE", lookat:=xlWhole, searchdirection:=xlPrevious).Row
            sData = Right(Cells(iRowD1, 4), Len(Cells(iRowD1, 4)) - 2)
            sWk.Cells(1, iCol) = sData
            Do While iOK1 = 0
                iOK1 = 1
                If iRowAA2 < iRowAA1 Then
                    iOK1 = 0
                    iRowAA2 = Range("A" & IIf(iRowAA2 = 0, iRowD1, iRowAA2) & ":A" & iRowAA1).Find(what:="OVERAGE RE", lookat:=xlWhole, searchdirection:=xlNext).Row
                    iCol1 = Cells(iRowAA2 + 2, Columns.Count).End(xlToLeft).Column
                    For x = 2 To iCol1 Step 2
                        If Cells(iRowAA2 + 3, x) <> "" Then
                            iRow1 = Cells(iRowAA2 + 2, x).End(xlDown).Row
                            For y = iRow1 To iRowAA2 + 3 Step -1
                                If IsNumeric(Cells(y, x - 1)) And Cells(y, x - 1) <> "" Then
                                    iRow1 = y
                                    Exit For
                                End If
                            Next
                            sCol1 = Split(Columns(x).Address(ColumnAbsolute:=False), ":")(1)
                            sCol2 = Split(Columns(iCol).Address(ColumnAbsolute:=False), ":")(1)
                            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
                    iRowAA2 = iRow1
                End If
            Loop
            iRowAA2 = 0
        End If
    Loop
    '
    sWk.Columns("A:" & sCol2).AutoFit
    sWk.Activate
    On Error GoTo 0
End If
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End Sub

A+

10feuil5.xlsm (55.17 Ko)
Le 20/12/2017 à 13:25

Bonjour.

La macro fonctionne très bien.

Par contre je souhaiterais en colonne B en la parcourant que lorsque un mots précis est trouver et bien entendu il y en a plusieurs supprime la prochaine ligne vide rencontre

Merci

Le 20/12/2017 à 13:33

Salut Kamellias,

tu ne pourrais pas être plus précis, par hasard ?

A+

Le 20/12/2017 à 14:06

désolé j'ai été un peu trop vite,

dans la macro que tu m'as faite fonctionne bien sauf que lorsque sur la colonne B des qu'une cellule vide est rencontre la macro s'arrête a ce niveau et dans ce cas une partie est pris en compte

je t'ai mis en couleur Jaune le souci en colonne B

Merci

6feuil5.xlsm (46.59 Ko)
Le 20/12/2017 à 15:12

Oui, en effet, j'ai zappé ce problème-là...

Je regarde ça dès que je peux.

A+

Le 21/12/2017 à 00:13

Salut Kamellias,

voilà...

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
            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(1, iCol) = sData
            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 2 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

A+

9feuil5.xlsm (53.03 Ko)
Le 21/12/2017 à 18:12

bonsoir Curulis,

Comme d'habitude c'est parfait, maintenant je peux adapter ton code et avancer sur mon projet.

UN TRES GRAND MERCI......

Le 21/12/2017 à 22:36

Le 30/12/2017 à 17:53

Salut Kamellias,

voici la correction demandée.

C'est ici que tu pourras choisir l'emplacement exact d'affichage de la date.

If sWk.[A1] = "" Then sWk.[A1] = Cells(iRowAA3, 2).Offset(-1, 0)

Meilleurs voeux!

A+

9feuil5.xlsm (52.89 Ko)
Le 30/12/2017 à 18:37

Je te remercie.

à toi aussi passe de bonnes fêtes et bonne année

Le 31/12/2017 à 09:32

Bonjour Curulis,

j'ai tester cette nuit la modification que tu m'a faite au niveau de la date par contre affiche seulement sur cellule A1

tu verras sur la feuille je t'ai mis en Rouge la partie a extraire sur feuil1 et sur La feuil2("Extract") en bleu le résultat souhaite

Merci de ton aide

4transposer.xlsm (63.50 Ko)
Le 31/12/2017 à 18:57

Salut Kamellias,

en effet, rien à voir avec la demande originelle de date où tu me renseignais la date en RUN TIME...

Voilà la correction!

            sWk.Cells(1, iCol) = Cells(iRowD1, 5)

Bon réveillon!

A l'année prochaine!

A+

5transposer.xlsm (52.52 Ko)
Le 31/12/2017 à 19:54

Merci Curulis,

Effectivement mon explications pas tres clair, a present tout fonctionne comme je le souhaite

promis je t'embete plus enfin pour cette année 2017 Par contre pour 2108 ?

Bonne soiree et bon reveillon....

Rechercher des sujets similaires à "extraire transposer"