Extraction données txt

Bonjour

Effectivement ca marche beaucoup mieux

tu a perdu du temps a cause de moi et je m'en excuse, mais n'oubli pas que j'avais prévenu que je suis nul sur excel.

Je bidouille un truc sur excel une fois tous les 2 ans.

En te remerciant de ta grande patience

Marc L a écrit :

Il devrait y avoir une évolution […]

Fort de ces enseignements, en voici une optimisation et, pour éviter un scrolling vers le bas de la feuille d'importation,

sélectionner sa cellule A3 puis figer les volets.

Code à coller où bon te semble :

Sub Macro2a()
Dim Rc As Range, Rg As Range, Rm As Range, Rp As Range
         P = ThisWorkbook.Path:  If P > "" Then ChDrive P: ChDir P
   FICHIER = Application.GetOpenFilename("Fichiers texte,*.txt", , "    Import  station  météo  :")
If FICHIER = False Then Exit Sub

With Feuil1
    If .FilterMode Then .ShowAllData
    .UsedRange.Clear:  .Cells(7).Value = "Import en cours …":  Application.ScreenUpdating = False

    With .QueryTables.Add("TEXT;" & FICHIER, .Cells(2))
               .AdjustColumnWidth = False
                    .RefreshStyle = xlOverwriteCells
         .TextFileColumnDataTypes = [{1,1,1,1,1,1,1,1,1,1,1,4}]
        .TextFileDecimalSeparator = ","
               .TextFileParseType = xlDelimited
                .TextFilePlatform = 1252
            .TextFileTabDelimiter = True
           .TextFileTextQualifier = xlTextQualifierNone
        .Refresh False:   .Delete
    End With
                FICHIER = Split(FICHIER, "\"):   .Name = FICHIER(UBound(FICHIER))
                If .Cells(2, 11).Value <> "[mm]" Then Beep: Exit Sub
                     Application.Calculation = xlCalculationAutomatic
                  Application.ReferenceStyle = xlA1
                .[B1:Q1].HorizontalAlignment = xlCenter
                              .[Q1:R1].Value = [{"mois","import"}]
                                      Set Rg = .Cells(2).CurrentRegion
    With Rg
                   .Columns("A:F").AutoFit:  .Columns("H:I").AutoFit
                          C& = .Rows.Count:  .Rows("3:" & C).Font.ColorIndex = 47
        With .Rows("2:" & C)
                          Union(.Columns(9), .Columns("K:L")).HorizontalAlignment = xlCenter
            With Union(.Columns("A:H"), .Columns(10))
                .HorizontalAlignment = xlRight:  .IndentLevel = 2:  .NumberFormat = "0.0"
            End With
        End With
    End With

    With .Cells(3, 17).Resize(C - 2)
         .FormulaR1C1 = "=TEXT(RC[-4],""" & String(3, Application.International(xlMonthCode)) _
                                    & " " & String(4, Application.International(xlYearCode)) & """)"
         .Offset(-2).Resize(C).AdvancedFilter xlFilterCopy, , .Offset(-2, -2), True
         F = "=SUMPRODUCT((" & .Address(, , xlR1C1) & "=RC[-1])*("
    End With

     Set Rm = .Cells(3, 15).CurrentRegion:         P = "{0"
    With Rm.Resize(, 2)
        .Font.ColorIndex = 47:  .HorizontalAlignment = xlRight:  .IndentLevel = 1
    End With

    For Each Rc In Rm
        If Evaluate("ISREF('" & Rc.Value & "'!A1)") = False Then
            With Worksheets.Add(, Worksheets(Worksheets.Count))
                .Name = Rc.Value:    Rg.Rows(1).Copy .Cells(2)
            End With
        End If
                P = P & "," & Worksheets(Rc.Value).UsedRange.Rows.Count
    Next
                P = Evaluate("MAX(" & P & "})")

    With .Cells(3, 18).Resize(C - 2)
         .FormulaR1C1 = "=SUMPRODUCT((INDIRECT(""'""&RC[-1]&""'!L1:L" & P & _
                        """)=RC[-6])*(INDIRECT(""'""&RC[-1]&""'!M1:M" & P & """)=RC[-5]))"
             .Formula = .Value:  F = F & .Address(, , xlR1C1) & "=0))":  P = .Address(, , , True)
    End With

    If Evaluate("=COUNTIF(" & P & ",0)") Then
        With Rm.Offset(, 1):  .FormulaR1C1 = F:  .Formula = .Value:  End With
                            .[P1:P2].Value = [{"import";0}]:        .Rows("1:2").Hidden = True
        For Each Rc In Rm
            If Rc.Offset(, 1).Value Then
                .Cells(2, 15).Value = Rc.Value:  Rc.Resize(, 2).Font.ColorIndex = 0
                .Cells(17).Resize(C, 2).AdvancedFilter xlFilterInPlace, .[O1:P2]

                With Worksheets(Rc.Value)
                      L& = .UsedRange.Rows.Count:  R& = L + 1
                                   Rg.Font.ColorIndex = 0:  Rg.Copy .Cells(R, 2)
                    If L = 1 Then
                        With .UsedRange:  .Columns("A:F").AutoFit:  .Columns("H:I").AutoFit:  End With
                    End If
                                        F = .Cells(L, 13).Value
                    Do
                                P = F:  F = .Cells(R, 13).Value
                        If F <> P Then
                            .Rows(R).Resize(3).Insert xlShiftDown
                            .Cells(R + 3, 13).Copy .Cells(R + 1, 7)
                            .Cells(R + 1, 7).Font.ColorIndex = 55
                        End If
                                Set Rp = .UsedRange.Columns(12).Find(F, .Cells(13), , , , xlPrevious)
                                 If Rp Is Nothing Then Exit Do Else R = Rp.Row + 1
                    Loop Until .Cells(R, 2).Value = ""

                    If L = 1 Then
                        .Activate:  .UsedRange.Rows(1).Interior.ColorIndex = 35
                        .Cells(3, 1).Select:      ActiveWindow.FreezePanes = True
                    End If
                End With
            End If
        Next
            .ShowAllData
    End If
            Union(.[O2:P2], .Cells(17).Resize(C, 2)).Clear
End With
            Set Rg = Nothing:  Set Rm = Nothing:  Set Rp = Nothing
End Sub

Impeccable

macro collée dans un module

Merci pour ton dévouement et ta patience.

Cdt

will60