VBA excel，如何从文件夹中选择文件并将代码应用于所有文件？

Question

在这段代码中：

1. 如何打开包含多个相同结构文件的文件夹，然后自动应用代码？
2. 显示了 3 个文件的代码，但文件夹中的所有文件都需要它，如何避免复制相同的内容？。
3. Al correr el código demora en llenar cada celda

子复制单元（）

Dim wbk1 As Workbook, wbk2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

strFirstFile = "E:\2020\Informes de Tutoría\18 semana\F3 S18 1A Isabel.xls"
strSecondFile = "D:\Nueva carpeta\4 Ficha-directivos-Seguimiento-Tutoria-Semana 16.xls"

Set wbk1 = Workbooks.Open(strFirstFile)
Set ws1 = wbk1.Sheets("F3")

Set wbk2 = Workbooks.Open(strSecondFile)
Set ws2 = wbk2.Sheets("F3")

With ws2
    .Range("g7").Value = ws1.Range("o34").Value
    .Range("m7").Value = ws1.Range("p34").Value
    .Range("q7").Value = ws1.Range("t33").Value
    .Range("T7").Value = ws1.Range("U33").Value
    .Range("V7").Value = ws1.Range("W33").Value
    .Range("W7").Value = ws1.Range("X38").Value
    .Range("X7").Value = ws1.Range("Z38").Value
   End With
    Workbooks(wbk1.Name).Close savechanges:=False

'Archivo1
Dim wbk11 As Workbook, wbk21 As Workbook
Dim ws11 As Worksheet, ws21 As Worksheet

strFirstFile = "E:\2020\Informes de Tutoría\18 semana\F3 S18 1B Jaime.xls"
strSecondFile = "D:\Nueva carpeta\4 Ficha-directivos-Seguimiento-Tutoria-Semana 16.xls"

Set wbk11 = Workbooks.Open(strFirstFile)
Set ws11 = wbk11.Sheets("F3")

Set wbk21 = Workbooks.Open(strSecondFile)
Set ws21 = wbk21.Sheets("F3")

With ws21

    .Range("g8").Value = ws11.Range("o34").Value
    .Range("m8").Value = ws11.Range("p34").Value
    .Range("q8").Value = ws11.Range("t33").Value
    .Range("T8").Value = ws11.Range("U33").Value
    .Range("V8").Value = ws11.Range("W33").Value
    .Range("W8").Value = ws11.Range("X38").Value
    .Range("X8").Value = ws11.Range("Z38").Value
    
End With
    Workbooks(wbk11.Name).Close savechanges:=False

'Archivo2
Dim wbk12 As Workbook, wbk22 As Workbook
Dim ws12 As Worksheet, ws22 As Worksheet

strFirstFile = "E:\2020\Informes de Tutoría\18 semana\F3 S18 1C David.xls"
strSecondFile = "D:\Nueva carpeta\4 Ficha-directivos-Seguimiento-Tutoria-Semana 16.xls"

Set wbk12 = Workbooks.Open(strFirstFile)
Set ws12 = wbk12.Sheets("F3")

Set wbk22 = Workbooks.Open(strSecondFile)
Set ws22 = wbk22.Sheets("F3")

With ws22

    .Range("g9").Value = ws12.Range("o34").Value
    .Range("m9").Value = ws12.Range("p34").Value
    .Range("q9").Value = ws12.Range("t33").Value
    .Range("T9").Value = ws12.Range("U33").Value
    .Range("V9").Value = ws12.Range("W33").Value
    .Range("W9").Value = ws12.Range("X38").Value
    .Range("X9").Value = ws12.Range("Z38").Value
    
End With
    Workbooks(wbk12.Name).Close savechanges:=False

结束子

Answer 1

请尝试此代码。但是，在您这样做之前，我建议您阅读所有 cmets 并尝试了解其逻辑。祝你好运。

Sub LoopThroughFolder()
    ' 078
    
    ' path name ends on a path separator
    Const PathName  As String = "E:\2020\Informes de Tutoría\18 semana\"
    
    Dim Fn          As String           ' File name
    Dim WbS         As Workbook         ' Source: Workbook
    Dim WsS         As Worksheet        ' Source: worksheet
    Dim BooksCount  As Integer          ' count of how many workbooks are open
    Dim WsT         As Worksheet        ' Target sheet (in ThisWorkbook)
    Dim Rt          As Long             ' Row: target
    
    Set WsT = Worksheets("F3")          ' define the sheet by name
    Fn = Dir(PathName)                  ' pick the first file in the folder
    Rt = 7                              ' first target row
    BooksCount = Workbooks.Count        ' count of how many workbooks are open
    Application.ScreenUpdating = False  ' speeds up the procedure
    
    Do While Len(Fn)                    ' loop if there is a file name
        Application.StatusBar = "Now processing " & Fn     ' show progress
        ' test if the file name meets your requirements
        If InStr(1, Fn, ".xl", vbTextCompare) And _
           (Fn <> ThisWorkbook.Name) Then
            Set WbS = Workbooks.Open(PathName & Fn)
            On Error Resume Next        ' in case the worksheet doesn't exist
            Set WsS = WbS.Worksheets("F3")
            If Err.Number = 0 Then
                With WsS
                    ' using 'Copy' will also transfer cell formatting
                    ' the alternative requires you  to apply formatting to WsT
                    ' WsT.Cells(Rt, "G").Value = .Range("O34").Value
                    .Range("O34").Copy Destination:=WsT.Cells(Rt, "G")
                    .Range("P34").Copy Destination:=WsT.Cells(Rt, "M")
                    .Range("T33").Copy Destination:=WsT.Cells(Rt, "Q")
                    .Range("U33").Copy Destination:=WsT.Cells(Rt, "T")
                    .Range("W33").Copy Destination:=WsT.Cells(Rt, "V")
                    .Range("X38").Copy Destination:=WsT.Cells(Rt, "W")
                    .Range("Z38").Copy Destination:=WsT.Cells(Rt, "X")
                End With
                Rt = Rt + 1
            End If
            
            WbS.Close SaveChanges:=False
            Do While Workbooks.Count > BooksCount
                DoEvents                        ' wait for WbS to close
            Loop
        End If
        Fn = Dir                                ' get the next file name
    Loop
    With Application
        .StatusBar = "Done"                     ' show progress
        .ScreenUpdating = True                  ' show final result
    End With
End Sub

请注意，我测试了循环位，但没有测试数据传输，这在很大程度上保持了您的方式。