XL 2016 Copier/coller selon critère dans colonne

[james7734]

Bonjour,

Je possède deux fichiers: un fichier source .txt et un fichier de destination. Mon code actuel permet d'ouvrir le fichier source .txt et de copier coller le contenu entier dans mon fichier de destination.
Cependant, j'aimerais seulement importer les lignes qui possède le critère "xx" en colonne L du fichier source et pas toutes les lignes.

Voici mon code actuel:

Sub OpenImportFile()
    Dim sFileName As String, DestFileName As String
    Dim sBase As String, test As String
    Dim sSuffix As String
    Dim sExt As String
    Dim shA As Worksheet
    Dim i As Integer
    Dim DEST As Range
    Dim RowNb As Long, ColNb As Long
Dim dtDébut As Double, dtFin As Double, n  As Integer
Dim dt As Double

    DestFileName = ThisWorkbook.Name
   

  Set shA = ThisWorkbook.Worksheets("Data")
  shA.Cells.ClearContents
       
dtDébut = Worksheets("Paramètres").Range("B9").Value
dtFin = Worksheets("Paramètres").Range("B10").Value
n = dtFin - dtDébut
  For i = 0 To n - 1
    dt = Format(dtDébut + i, "yyyymmdd")
    sBase = "F:\Fastnet\Fastnet2020\"
    sExt = "FastnetI.fic"
    sFileName = sBase & dt & sExt
           
    test = Dir(sFileName)
    If test <> "" Then
   
        Workbooks.OpenText sFileName, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, Local:=True, DecimalSeparator:="."
       
        RowNb = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
        ColNb = Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column

        If i = 0 Then
            ActiveWorkbook.Worksheets(1).Range(Cells(1, 1), Cells(RowNb, ColNb)).Copy
        Else
            ActiveWorkbook.Worksheets(1).Range(Cells(2, 1), Cells(RowNb, ColNb)).Copy
        End If
        Workbooks(DestFileName).Worksheets("Data").Activate
        If i = 0 Then
            Cells(Application.Rows.Count, "A").End(xlUp).Select
        Else
            Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0).Select
        End If
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Workbooks(dt & sExt).Close savechanges = False
       
          End If
   Next
   
End Sub

 

[sousou]

Re suite je suppose?
tu peux t’inspirer de ceci.
Sub deb()
chemin = ThisWorkbook.Path & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fich = fso.getfile(chemin & "fichier source.txt")
Set fichs = fich.OpenAsTextStream(1)

While fichs.Atendofline <> True
phrase = fichs.readline
If InStr(phrase, "xx") <> 0 Then
drlg = ActiveSheet.Cells(ActiveSheet.UsedRange.Count + 1, 1).End(xlUp).Row + 1
ActiveSheet.Cells(drlg, 1) = phrase

ActiveSheet.Cells(drlg, 1).TextToColumns Destination:=ActiveSheet.Cells(drlg, 1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array( _
46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), _
Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array( _
59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 1), _
Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), Array(71, 1), Array( _
72, 1), Array(73, 1), Array(74, 1), Array(75, 1), Array(76, 1), Array(77, 1), Array(78, 1), _
Array(79, 1), Array(80, 1), Array(81, 1), Array(82, 1), Array(83, 1), Array(84, 1), Array( _
85, 1), Array(86, 1), Array(87, 1), Array(88, 1), Array(89, 1), Array(90, 1), Array(91, 1), _
Array(92, 1), Array(93, 1), Array(94, 1), Array(95, 1), Array(96, 1)), _
TrailingMinusNumbers:=True
MsgBox phrase
End If
Wend
End Sub

 

[Pounet95]

Bonsoir,
Avec un filtre peut-être ?
Dis-nous !


Sub Copie_Plage_Visible()
Dim plgVisible As Range 'la plage qui sera copiee
Dim derLig As Long 'derniere ligne du fichier

'On supoose que la feuille active est celle dont on extrait les lignes ayant "xx" en colonne L
derLig = [A10000].End(xlUp).Row
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("A1:CR" & derLig).AutoFilter Field:=12, Criteria1:="xx"

'Avec la ligne entete
Set plgVisible = Range("A1:CR" & derLig).SpecialCells(xlCellTypeVisible)

'sans la ligne entete
Set plgVisible = Range("A2:CR" & derLig).SpecialCells(xlCellTypeVisible)

'selectionne et copie
plgVisible.Copy

'Retour dans le classeur
ThisWorkbook.Activate
Sheets("Nom feuille").Activate

Rows("x:x").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub