将工作表导入一个excel工作簿 [英] Importing worksheets into one excel workbook

问题描述

我有一个包含111个excel工作簿的文件夹。我想将每个文件复制并粘贴到一个excel文件中，分成几页。所以一张表应该有一个文件的内容。每个文件只包含一个工作表。任何想法都会有帮助，因为我对VBA并不十分熟悉。而且我不想复制粘贴111次。

谢谢。

解决方案

最近我有同样的问题。这个代码是你需要的。指定一个文件夹，它将所有工作簿组合成一个（即使他们有多个工作表也可以处理它们）。

 '在http://www.vbaexpress.com/kb/getarticle.php?kb_id=829 
 
选项显式
 
 '32位API声明
声明函数SHGetPathFromIDList Libshell32.dll_ 
别名SHGetPathFromIDListA（ByVal pidl As Long，ByVal _ 
 pszpath As String）As Long 
 
声明函数SHBrowseForFolder Libshell32.dll_ 
别名SHBrowseForFolderA（lpBrowseInfo As BrowseInfo）_ 
 As Long 
 
公共类型BrowseInfo 
 hOwner As Long 
 pIDLRoot As Long 
 pszDisplayName As String 
 lpszTitle As String 
 ulFlags As Long 
 lpfn As Long 
 lParam As Long 
 iImage As Long 
结束类型
 
函数GetDirectory（可选的msg）As String 
错误恢复Next 
 Dim bInfo As BrowseInfo 
 Dim路径As String 
 Dim r As Long，x As Long，pos As Integer 
 
'根文件夹= Desktop 
 bInfo.pIDLRoot = 0& 
 
'对话框中的标题
如果IsMissing（msg）然后
 bInfo.lpszTitle =请选择要复制的Excel文件的文件夹。 
 Else 
 bInfo.lpszTitle = msg 
如果
 
'要返回的目录类型
 bInfo.ulFlags =& H1 
 
'显示对话框
x = SHBrowseForFolder（bInfo）
 
'解析结果
 path =空格$（512）
r = SHGetPathFromIDList（ByVal x，ByVal路径）
如果r然后
 pos = InStr（path，Chr $（0））
 GetDirectory = Left（path，pos  -  1）
 Else 
 GetDirectory = 
 End If 
 End Function 
 
 Sub CombineFiles（）
 Dim path As String 
 Dim FileName As String 
 Dim LastCell As range 
 Dim Wkb As Workbook 
 Dim ws As Worksheet 
 Dim ThisWB As String 
 
 ThisWB = ThisWorkbook.Name 
 Application.EnableEvents = False 
 Application.ScreenUpdating = False 
 path = GetDirectory 
 FileName = Dir（path&\ * .xls， vbNormal）
 Do Until FileName =
如果FileName<>然后
设置Wkb = Workbooks.Open（FileName：= path&\& FileName）
对于每个ws在Wkb.Worksheets 
设置LastCell = ws.cells.SpecialCells （xlCellTypeLastCell）
如果LastCell.Value =和LastCell.Address = range（$ A $ 1）。然后
 Else 
 ws.Copy After：= ThisWorkbook.Sheets（ThisWorkbook .Sheets.count）
结束如果
下一个ws 
 Wkb.Close False 
结束If 
 FileName = Dir（）
循环
应用程序.EnableEvents = True 
 Application.ScreenUpdating = True 
 
设置Wkb = Nothing 
设置LastCell = Nothing 
 End Sub 
  

I have a folder with 111 excel work books. I want to copy and paste every file into one excel file into separate sheets. So one sheet should have the contents of one file. Each file contains only one sheet. Any ideas would help as i am not very familiar with VBA. And I don't want to copy and paste 111 times.

Thanks.

解决方案

I had the same issue recently. This code is all you need. Specify a folder and it will combine all workbooks into one (handles them even if they have multiple sheets, too).

' found at: http://www.vbaexpress.com/kb/getarticle.php?kb_id=829

Option Explicit

 '32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long

Public Type BrowseInfo
    hOwner As Long
    pIDLRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Function GetDirectory(Optional msg) As String
    On Error Resume Next
    Dim bInfo As BrowseInfo
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

     'Root folder = Desktop
    bInfo.pIDLRoot = 0&

     'Title in the dialog
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Please select the folder of the excel files to copy."
    Else
        bInfo.lpszTitle = msg
    End If

     'Type of directory to return
    bInfo.ulFlags = &H1

     'Display the dialog
    x = SHBrowseForFolder(bInfo)

     'Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Sub CombineFiles()
    Dim path            As String
    Dim FileName        As String
    Dim LastCell        As range
    Dim Wkb             As Workbook
    Dim ws              As Worksheet
    Dim ThisWB          As String

    ThisWB = ThisWorkbook.Name
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    path = GetDirectory
    FileName = Dir(path & "\*.xls", vbNormal)
    Do Until FileName = ""
        If FileName <> ThisWB Then
            Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
            For Each ws In Wkb.Worksheets
                Set LastCell = ws.cells.SpecialCells(xlCellTypeLastCell)
                If LastCell.Value = "" And LastCell.Address = range("$A$1").Address Then
                Else
                    ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
                End If
            Next ws
            Wkb.Close False
        End If
        FileName = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    Set Wkb = Nothing
    Set LastCell = Nothing
End Sub

这篇关于将工作表导入一个excel工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！