vba - 扫描子文件夹并测试和特定的cel

Question

早上好，我想创建一个代码，允许我选择一个带有 filedialog 的文件夹（通过 filedialog 选择），然后从这个文件夹中，代码将在所有子文件夹中查找一个特定的 excel 文件，在这个文件中选择那个表我感兴趣。然后对于这张表的每一行，如果这个单元格不为空（它包含一个值），则有必要测试单元格“X”然后我复制这一行，但只复制列 F、G、P、Q、X、Y然后将其粘贴到我事先选择的目标工作簿中。你会找到我所做的草稿谢谢你的帮助和时间

**

   Dim Fso As Object
        Dim f1 As Object, f2 As Object
        Dim sh As Excel.Worksheet                   'sh pour sheet
        Dim SourceWB As Excel.Workbook              'WB pour workbook
        Dim DestinationWB As Excel.Workbook
        Dim subf As Variant 'i created a file dialog in a function to let me chose the folder i want
        Dim i As Integer
        Dim j As Long
        Dim SheetCnt As Integer 'sheetcount compteur pour itération, contient le nombre de feuille dans le fichier
        Dim lstRow1 As Long
        Dim lstRow2 As Long
        Dim lstCol As Integer   'last colum, permet de la dernière colonne où l'on possède une donnée
        Dim ws1 As Worksheet
        Private Sub extractionAl_Click()
        With Application
                .DisplayAlerts = False
                .EnableEvents = False
                .ScreenUpdating = False
            End With
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set DestinationWB = Application.ThisWorkbook
         lstRow2 = alarmes.Cells(alarmes.Rows.Count, "A").End(xlUp).Row
        alarmes.Cells.Range("A2:K" & lstRow2 + 1).ClearContents
        lstRow2 = 2
        For Each f1 In Fso.GetFolder(subf).subfolders
        For Each f2 In f1.Files
            If f2 Like "*indicateur*" Then
        Set SourceWB = Workbooks.Open(f2, ReadOnly:=True)
            For Each sh In SourceWB.Worksheets
                       If sh.Name = "EIF-EIVT-EIPR-EIE mensuelles" Then
                       lstRow1 = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
                For i = 1 To lstRow1
                       If sh.Range("X" & i).Value <> "" Then
                'I WANT TO COPY THE LINE BUT ONLY COLUMNS F,G,P,Q,X,Y
                      End If

                       DestinationWB.Activate
                       alarmes.Range("A" & lstRow2).PasteSpecial 'xlPasteValues
                       Application.CutCopyMode = False
                       lstRow2 = alarmes.Cells(alarmes.Rows.Count, "A").End(xlUp).Row + 1

                        End If
               Next sh


          Workbooks(f2.Name).Saved = True

           Workbooks(f2.Name).Close

    End If
Next f2
Next f1
End Sub

**

标签： vbaexcel

Answer 1

尝试，

...
If sh.Range("X" & i).Value <> "" Then
    intersect(sh.rows(i), sh.range("F:G, P:Q, X:Y")).copy _
        destination:=DestinationWB.worksheets("alarmes").cells(lstRow2, "A")
    lstRow2 = lstRow2 + 1
End If
...