我正在尝试遍历各种工作簿中的工作表并复制值(从单个单元格开始)。我需要将复制的值粘贴到新工作簿中的一个新工作表中,该工作簿在第一行中的另一个下面。
目前,我使用三本工作簿。每个工作簿都有两页。
出现以下问题:即使我循环浏览三个工作簿中的所有工作表,也只会将第二个工作表中的值复制到主文件中。有人看到这个问题吗?非常感谢您的帮助!
Sub RunOnAllFilesInFolder()
Dim folderName As String, eApp As Excel.Application, fileName As String
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
Dim ID As String
Dim counter As Integer
Dim i As Integer
counter = 2
fDialog.Title = "Select a folder"
fDialog.InitialFileName = currWb.Path
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
Set eApp = New Excel.Application: eApp.Visible = False
Set eApp2 = New Excel.Application: eApp.Visible = False
Set wb2 = eApp2.Workbooks.Add
fileName = Dir(folderName & "\*.xls")
Do While fileName <> ""
Application.StatusBar = "Processing " & folderName & "\" & fileName
Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)
For Each ws In wb.Worksheets
ws.Range("A1").Copy
Next ws
wb2.Worksheets(1).Cells(counter, 1).PasteSpecial xlPasteValues
wb.Close SaveChanges:=False
Debug.Print "Processed" & folderName & "\" & fileName
fileName = Dir()
counter = counter + 1
Loop
wb2.SaveAs ("Results.xlsx")
eApp.Quit
Set eApp = Nothing
eApp2.Quit
Set eApp2 = Nothing
Application.StatusBar = ""
MsgBox "Completed executing Macro"
End Sub
看起来问题出在您的工作表循环中。您正在从工作表中复制内容,但是将值粘贴到工作表循环之后。这就是为什么您仅从一张纸获得价值的原因。下面的代码将为您工作。
Sub RunOnAllFilesInFolder()
Dim folderName As String, eApp As Excel.Application, fileName As String
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
Dim ID As String
Dim counter As Integer
Dim i As Integer
counter = 2
fDialog.Title = "Select a folder"
fDialog.InitialFileName = currWb.Path
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
Set eApp = New Excel.Application: eApp.Visible = False
Set eApp2 = New Excel.Application: eApp.Visible = False
Set wb2 = eApp2.Workbooks.Add
fileName = Dir(folderName & "\*.xls")
Do While fileName <> ""
Application.StatusBar = "Processing " & folderName & "\" & fileName
Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)
For Each ws In wb.Worksheets
ws.Range("A1").Copy
wb2.Worksheets(1).Cells(counter, 1).PasteSpecial xlPasteValues
counter = counter + 1
Next ws
wb.Close SaveChanges:=False
Debug.Print "Processed" & folderName & "\" & fileName
fileName = Dir()
Loop
wb2.SaveAs ("Results.xlsx")
eApp.Quit
Set eApp = Nothing
eApp2.Quit
Set eApp2 = Nothing
Application.StatusBar = ""
MsgBox "Completed executing Macro"
End Sub