Vba 遍历具有值的文件夹

Question

我真的是 vba 宏编写的初学者，我遇到了一个问题。我查找了一个循环宏，它循环一个文件夹中的文件并合并一个。问题是某些文件具有函数，因此在某些列中我面临参考问题，因此我需要值而不是函数。我一直在寻找解决方案两天，但没有任何进展。我是一家跨国公司的实习生，这会让我的工作更轻松。这是我的宏：

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("IT&SYS")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close True
    End With
    MyFile = Dir()
 Loop

Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("Prof Cons")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close True
    End With
    MyFile = Dir()

Loop

Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("Travel")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close True
    End With
    MyFile = Dir()

Loop


Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("Conference&Entertainment")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close True
    End With
    MyFile = Dir()

Loop

Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("Staff Rel")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close True
    End With
    MyFile = Dir()

Loop

Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("Other")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet6").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close True
    End With
    MyFile = Dir()

 Loop

Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("Facilities&Real Estate")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet7").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close True
    End With
    MyFile = Dir()

Loop
End Sub

Answer 1

您需要分两行而不是一行来完成 .Copy 和 .Paste：

With Worksheets("Travel")
    Rws = .Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
    Rng.Copy 
    Wb.Worksheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    ActiveWorkbook.Close True
End With

此外，同意大家的看法，最好是使用一个循环，处理该循环内的每个工作表。

类似于：

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
MyFile = Dir(MyDir & "*.xl??")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
    Workbooks.Open (MyFile)
    With Worksheets("IT&SYS")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy 
        Wb.Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues        
    End With
    With Worksheets("Prof Cons")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy 
        Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues       
    End With
    With Worksheets("Travel")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy Wb.Worksheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues        
    End With
    With Worksheets("Conference&Entertainment")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy 
        Wb.Worksheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues        
    End With
    With Worksheets("Staff Rel")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy 
        Wb.Worksheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues        
    End With
    With Worksheets("Other")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy 
        Wb.Worksheets("Sheet6").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues       
    End With
    With Worksheets("Facilities&Real Estate")
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(1, 35), .Cells(Rws, 2))
        Rng.Copy 
        Wb.Worksheets("Sheet7").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)       
    End With
    ActiveWorkbook.Close True
    MyFile = Dir()
 Loop




End Sub

这仍然可以清理，因为这里有很多 copy/paste 代码，但这会更有效率。

Answer 2

您的重复块可以是一个单独的过程，您可以使用不同的参数调用。
请注意，您多次循环文件。
根本不使用复制，而是传输范围值。
我会怎么做：

Sub LoopThroughFolder()
    Dim MyFile As String, MyDir As String ',Str As String <- not used
    Dim Wb As Workbook
    MyDir = "D:\PersonalData\BodaBali\Desktop\vba loop\"
    MyFile = Dir(MyDir & "*.xl??")
    ChDir MyDir
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Do While MyFile <> ""
        Set Wb = Workbooks.Open(MyFile)
        HelpSub Wb.Worksheets("Prof Cons"), ThisWorkbook.Worksheets("Sheet1")
        HelpSub Wb.Worksheets("IT&SYS"), ThisWorkbook.Worksheets("Sheet2")
        HelpSub Wb.Worksheets("Travel"), ThisWorkbook.Worksheets("Sheet3")
        HelpSub Wb.Worksheets("Conference&Entertainment"), ThisWorkbook.Worksheets("Sheet4")
        HelpSub Wb.Worksheets("Staff Rel"), ThisWorkbook.Worksheets("Sheet5")
        HelpSub Wb.Worksheets("Other"), ThisWorkbook.Worksheets("Sheet6")
        Wb.Close False
        MyFile = Dir()
    Loop
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub
Private Sub HelpSub(wsSource As Worksheet, wsDestination As Worksheet)
    Dim Rng As Range, Rws As Long
    With wsSource
        Rws = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(1, 35), .Cells(Rws, 2))
        wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp). _
            Offset(1, 0).Resize(Rng.Rows.Count, Rng.Columns.Count).Value = Rng.Value
    End With
End Sub

Vba 遍历具有值的文件夹

Vba loop through folders with values

excel

vba

loops

consolidation