使用Excel进行数据提取

Question

我每月收到100多个excel电子表格,我将采用固定范围并粘贴到其他电子表格中进行报告.

我试着写一个vba脚本迭代我的excel文件并在一个电子表格中复制范围,但我还没能做到.

是否有捷径可寻？

Answer 1

这里有一些VBA代码,演示了在目录中迭代一堆Excel文件并打开每个文件:

Dim sourcePath As String
Dim curFile As String
Dim curWB As Excel.Workbook
Dim destWB As Excel.Workbook

Set destWB = ActiveWorkbook
sourcePath = "C:\files"

curFile = Dir(sourcePath & "\*.xls")
While curFile <> ""
    Set curWB = Workbooks.Open(sourcePath & "\" & curFile)

    curWB.Close
    curFile = Dir()
Wend 

希望这对您来说是一个很好的起点,可以使用现有的宏代码.

Answer 2

我几年前写过这篇文章，但也许​​它会对你有所帮助。我添加了最新版本 Excel (xlsx) 的扩展名。似乎有效。

Sub MergeExcelDocs()
    Dim lastRow As Integer
    Dim docPath As String
    Dim baseCell As Excel.range
    Dim sysObj As Variant, folderObj As Variant, fileObj As Variant
    Application.ScreenUpdating = False
    docPath = Application.GetOpenFilename(FileFilter:="Text Files (*.txt),*.txt,Excel Files (*.xls),*.xls,Excel 2007 Files (*.xlsx),*.xlsx", FilterIndex:=2, Title:="Choose any file")
    Workbooks.Add
    Set baseCell = range("A1")
    Set sysObj = CreateObject("scripting.filesystemobject")
    Set fileObj = sysObj.getFile(docPath)
    Set folderObj = fileObj.ParentFolder
    For Each fileObj In folderObj.Files
        Workbooks.Open Filename:=fileObj.path
        range(range("A1"), ActiveCell.SpecialCells(xlLastCell)).Copy
        lastRow = baseCell.SpecialCells(xlLastCell).row
        baseCell.Offset(lastRow, 0).PasteSpecial (xlPasteValues)
        baseCell.Copy
        ActiveWindow.Close SaveChanges:=False
    Next
End Sub

编辑：

我应该提到它是如何工作的。当您启动宏时，它会弹出一个“打开文件”对话框。双击列表中的第一个文件（或任何与此相关的文件）。它将创建一个新的工作簿，然后循环遍历文件夹中的所有文件。对于每个文件，它会复制第一个工作表中的所有内容并将其粘贴到新工作簿的末尾。这几乎就是全部内容了。