vba - 在文件夹中打开、复制、粘贴关闭和循环文件

Question

我有一个包含 50 个 excel 文件的文件夹，我需要打开、复制、粘贴、关闭和打开下一个。宏一直工作到循环，但它没有打开下一个文件。它停止任何建议？

Sub open_and_close()

Dim MyFolder As String
Dim MyFile As Variant
Dim LC3 As Long
Dim WB1 As Workbook
Dim WB2 As Workbook

Set WB1 = ThisWorkbook

MyFolder = "C:\Users\x\y\z\Test script\"
MyFile = Dir(MyFolder & "*.xlsx")

Do While MyFile <> ""
    Workbooks.Open (MyFolder & MyFile)
    Set WB2 = ActiveWorkbook
    ActiveWorkbook.Sheets("Test Script Scenario 1").Range("J3:J99").Copy
    WB1.Sheets("Test Script Scenario 1").Activate
    LC3 = Cells(3, Columns.Count).End(xlToLeft).Column
    Cells(3, LC3 + 1).PasteSpecial Paste:=xlPasteValues
    Cells(1, LC3 + 1) = Dir(WB2.Name)
    WB2.Close savechanges:=False
    MyFile = Dir()
Loop
End Sub

标签： vbaloops

Answer 1

我总是避免 DIR，因为如果多次调用它，它的行为就会很奇怪。我认为这是你的问题——正如你所说的 Dir(wb2.name)。

尝试使用 FilesystemObject。您必须添加对项目的引用：

此外，没有必要复制/粘贴 >> 参见 sub copyRangeValues

另外：考虑使用表格（插入>表格）比添加新列容易得多。

Option Explicit

Private Const pathToFiles As String = "C:\Users\x\y\z\Test script\"

Private Const SourceSheetname As String = "Test Script Scenario 1"
Private Const SourceAddressToCopy As String = "J3:J99"

Private Const TargetSheetname As String = "Test Script Scenario 1"
Private Const TargetStartRow As Long = 3




Sub readDataFromFiles()

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim SourceFolder As Folder
Set SourceFolder = fso.GetFolder(pathToFiles)

Dim SourceFile As File, wbSource As Workbook

For Each SourceFile In SourceFolder.Files
    If SourceFile.Name Like "*.xlsx" Then
        Set wbSource = getWorkbook(pathToFiles & "\" & SourceFile.Name)
        copyDataFromSource wbSource
        wbSource.Close False
    End If
Next

End Sub




Private Sub copyDataFromSource(wbSource As Workbook)

Dim rgSource As Range
Set rgSource = wbSource.Worksheets(SourceSheetname).Range(SourceAddressToCopy)

Dim rgTargetCell As Range
Set rgTargetCell = getTargetCell

copyRangeValues rgSource, rgTargetCell

'add filename to row 1
rgTargetCell.Offset(TargetStartRow - 2).Value = wbSource.Name

End Sub




Private Function getTargetCell() As Range

Dim wsTarget As Worksheet: Set wsTarget = ThisWorkbook.Worksheets(TargetSheetname)

'I copied your code - but it looks weird to me
'think of using a table and then your can work with the listobject to add a new column
Dim LC3 As Long
With wsTarget
    LC3 = .Cells(3, .Columns.Count).End(xlToLeft).Column
End With

Set getTargetCell = wsTarget.Cells(TargetStartRow, LC3)

End Function




Public Sub copyRangeValues(rgSource As Range, rgTargetCell As Range)
'generic routine to copy one range to another
'rgTargetCell = top left corner of target range

Dim rgTarget As Range
'resize rgTarget according to dimensions of rgSource
With rgSource
    Set rgTarget = rgTargetCell.Resize(.Rows.Count, .Columns.Count)
End With

'write values from rgSource to rgTarget - no copy/paste necessary!!!
'formats are not copied - only values
rgTarget.Value = rgSource.Value

End Sub




Private Function getWorkbook(FullFilename As String) As Workbook
Dim wb As Workbook
Set wb = Application.Workbooks.Open(FullFilename)
Set getWorkbook = wb
End Function