Sub Extract()
Dim F As Worksheet, fichier As Variant, i&, x$, tablo, n&, j%
Set F = Feuil16 'CodeName de la feuille "Informations", à adapter
fichier = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If fichier = False Then Exit Sub
Application.ScreenUpdating = False
F.Cells.Delete 'RAZ
i = InStrRev(fichier, "\")
x = "'" & Left(fichier, i) & "[" & Mid(fichier, i + 1) & "]" & F.Name & "'!"
On Error Resume Next
i = ExecuteExcel4Macro("MATCH(""zzz""," & x & "C1)") 'dernière ligne
With F.[A1].Resize(i, 6)
.FormulaArray = "=" & x & .Address 'formule de liaison matricielle
tablo = .Value
For i = 1 To UBound(tablo)
If tablo(i, 5) <> 0 Or tablo(i, 6) <> 0 Then
n = n + 1
For j = 1 To 6
tablo(n, j) = IIf(tablo(i, j) = 0, "", tablo(i, j))
Next j
End If
Next i
.ClearContents 'RAZ
.Resize(n) = tablo 'restitution
End With
With F.ListObjects.Add(xlSrcRange, F.UsedRange, , xlYes)
.Name = "Tableau1"
.TableStyle = "TableStyleMedium13" 'style modifiable
End With
F.Columns(3).Resize(, 4).HorizontalAlignment = xlCenter 'centrage
F.Columns.AutoFit 'ajustement largeur
F.[H1] = fichier
F.Activate 'facultatif
End Sub