Question

早上好，我想创建一个代码，该代码允许我选择一个带有文件对话框的文件夹（通过文件对话框进行选择），然后从该文件夹中的代码在所有子文件夹中寻找一个特定的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

**

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
...

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

1 个答案: