从多个Excel提取数据到Main Excel [英] Fetching the data from multiple excel to the Main Excel

问题描述

我在同一文件夹中有5个名为Report1，Report2，Report3，Report4，Report5的Excel工作表，我想创建主ExcelSheet"MainReport"

在五个Excel工作表(Report1至5)中的每个工作表中都有一个名为MainSheet的工作表.我想从每个excel的MainSheet中获取数据到MainExcel即

• 在Main Excel中从Report1到Sheet1的MainSheet
• 在Main Excel中从Report2到Sheet2的MainSheet
• .
• .
• 从Report5到Main Excel中Sheet5的MainSheet

预先感谢

解决方案

摘自我的文章从一个或多个工作表中整理工作表将更多工作簿添加到EE托管的摘要文件中

此代码提供了三个选项，用于合并文件夹中的Excel文件:

1. 将一个文件夹中所有Excel工作簿的所有工作表整理到一个摘要工作表中
2. 将所有Excel工作簿中的所有工作表整理到一个文件夹中
3. 将一个Excel工作簿中的所有工作表整理到一个摘要工作表中

选项(2)听起来像您想要的

  Public Sub ConsolidateSheets()昏暗的Wb1作为工作簿昏暗的Wb2作为工作簿昏暗的ws1作为工作表昏暗的ws2作为工作表昏暗的ws3作为工作表Dim rng1作为范围Dim rng2作为范围Dim rng3作为范围昏暗区域作为范围昏暗的LrowSpace只要长尽可能长的暗淡尽可能长的Dim lngCalc调光行尽可能长的昏暗颜色昏暗的X()昏暗bProcessFolder为布尔将bNewSheet设置为布尔值Dim StrPrefix昏暗的strFileName作为字符串昏暗的strFolderName作为字符串'Shell对象使用默认目录所需的变量声明Dim strDefaultFolder作为变体bProcessFolder =(MsgBox(处理单个文件夹(是)，"& vbNewLine&或单个文件(否)"，vbYesNo，应用程序范围:文件夹或单个文件")= vbYes)bNewSheet =(MsgBox(将所有数据提取到单个工作表中(是)，"& vbNewLine&或每个源工作表的目标文件工作表(否)"，vbYesNo，输出格式:单个工作表或一个工作表集合")= vbYes)如果不是bProcessFolder然后如果不是bNewSheet，则MsgBox创建源文件的精确副本没有多大意义:)"退出子万一万一'如果需要，在此处设置默认目录strDefaultFolder ="C:\ temp"'如果用户将所有工作表都整理为一个目标工作表，则行间距'区分不同的表可以在这里设置lrowSpace = 1如果bProcessFolder然后strFolderName = BrowseForFolder(strDefaultFolder)'查找xls，xlsx，xlsm文件strFileName = Dir(strFolderName&"\ *.xls *")别的strFileName =应用程序_.GetOpenFilename(选择要处理的文件(* .xls *)，*.xls *")万一设置Wb1 = Workbooks.Add(1)设置ws1 = Wb1.Sheets(1)如果不是bNewSheet，则ws1.Range("A1:B1")= Array(工作簿名称"，工作表计数")'关闭屏幕更新，事件，警报并将计算设置为手动随着申请.DisplayAlerts =假.EnableEvents =假.ScreenUpdating = FalselngCalc =.计算.Calculation = xlCalculationManual结束于'在循环外设置路径StrPrefix = strFolderName&IIf(bProcessFolder，"\"，vbNullString)做While Len(strFileName)>0'向用户提供进度状态Application.StatusBar = Left("Processing"& strFolderName&"\"& strFileName，255)'在感兴趣的文件夹中打开每个工作簿设置Wb2 = Workbooks.Open(StrPrefix& strFileName)如果不是bNewSheet，则'将摘要详细信息添加到第一张工作表ws1.Cells(Rows.Count，"A").End(xlUp).Offset(1，0)= Wb2.Namews1.Cells(Rows.Count，"A").End(xlUp).Offset(0，1)= Wb2.Sheets.Count万一对于Wb2.Sheets中的每个ws2如果bNewSheet然后'所有数据都在一张纸上'如果源工作表为空白，则跳过导入目标工作表数据设置rng2 = ws2.Cells.Find("*"，ws2.[a1]，xlValues，xlByRows，xlPrevious)如果不是rng2什么都没有，那么设置rng1 = ws1.Cells.Find("*"，ws1.[a1]，xlValues，xlByRows，xlPrevious)'在目标工作表上找到第一行空白如果不是rng1什么都没有，那么设置rng3 = ws2.Range(ws2.UsedRange.Cells(1)，ws2.Cells(rng2.Row，"A"))'确保不会超出目标工作表中的行区域如果rng3.Rows.Count + rng1.Row<行数然后'将数据从每个原始工作表的使用范围复制到第一行空白'，使用要复制的源工作表中的起始列地址ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace，ws2.UsedRange.Cells(1).Column)别的MsgBox超过了摘要纸的大小.进程在&vbNewLine&_"工作表:&ws2.Name&vbNewLine&的"&vbNewLine&工作簿:"&Wb2.NameWb2.Close False退出做万一'为所有间隔行中的第一行上色如果lrowSpace<>0然后ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen别的目标表为空，因此请复制到第一行ws2.UsedRange.Copy ws1.Cells(1，ws2.UsedRange.Cells(1).Column)万一万一别的'每个源工作表的新目标工作表ws2.Copy after:= Wb1.Sheets(Wb1.Sheets.Count)'删除目标表中的所有链接随着Wb1.Sheets(Wb1.Sheets.Count).Cells.复制.PasteSpecial xlPasteValues结束于关于错误继续Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name'工作表名称已存在于目标工作簿中如果Err.Number<>0然后'在工作表名称上添加一个数字，直到获得唯一的名称为止做lSht = lSht + 1设置ws3 = Wb1.Sheets(ws2.Name&& lSht)没有ws3却没有循环lSht = 0万一出错时转到0万一下一个ws2'关闭打开的工作簿Wb2.Close False'如果处理单个文件，请检查是否强制退出DO循环如果bProcessFolder = False，则退出DostrFileName =目录环形'如果用户使用了目标表，则删除所有链接如果bNewSheet然后与ws1.UsedRange.复制.Cells(1).PasteSpecial xlPasteValues.Cells(1).激活结束于别的'如果用户创建了单独的目标表，则格式化摘要表ws1.Activatews1.Range("A1:B1").Font.Bold = Truews1.Columns.AutoFit万一随着申请.CutCopyMode =假.DisplayAlerts =真.EnableEvents = True.ScreenUpdating =真.Calculation = lngCalc.StatusBar = vbNullString结束于结束子函数BrowseForFolder(可选，OpenAt为Variant)为Variant'摘自Ken Puls在vbaexpress.com文章中使用的'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284昏暗的ShellApp作为对象'在默认文件夹中创建文件浏览器窗口设置ShellApp = CreateObject("Shell.Application")._BrowseForFolder(0，请选择一个文件夹"，0，OpenAt)'将文件夹设置为选定的文件夹.(如果发生错误，则取消)关于错误继续BrowseForFolder = ShellApp.self.Path出错时转到0'销毁Shell应用程序设置ShellApp = Nothing'检查无效或非输入并发送至无效错误'处理程序(如果找到)'有效的选择可以以L :(其中L是字母)开头或'\\(与\\ servername \ sharename相同.其他所有无效选择案例中间(BrowseForFolder，2，1)大小写为=:"如果Left(BrowseForFolder，1)=:"，则GoTo无效大小写为="\"如果未剩余(BrowseForFolder，1)="\"，则转到无效其他情况转到无效结束选择退出功能无效的:'如果确定选择无效，则设置为FalseBrowseForFolder = False结束功能 

I have 5 Excel Sheets named Report1, Report2, Report3, Report4, Report5 in the same folder and I want create main ExcelSheet "MainReport"

There is a sheet named MainSheet in each of the five excel sheets (Report1 to 5) I want to fetch the data from the MainSheet of the each excel to the MainExcel i.e

• MainSheet from Report1 to the Sheet1 in Main Excel
• MainSheet from Report2 to the Sheet2 in Main Excel
• .
• .
• MainSheet from Report5 to the Sheet5 in Main Excel

Thanks in advance

解决方案

From my article Collating worksheets from one or more workbooks into a summary file hosted at EE

This code provides three options to combine Excel files sitting in a folder:

1. Collate all sheets from all Excel workbooks in a single folder into a single summary worksheet
2. Collate all sheets from all Excel workbooks in a single folder into a single summary workbook
3. Collate all sheets from a single Excel workbook into a single summary worksheet

Option (2) sounds to be what you want

Public Sub ConsolidateSheets()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngArea As Range
    Dim lrowSpace As Long
    Dim lSht As Long
    Dim lngCalc As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim X()
    Dim bProcessFolder As Boolean
    Dim bNewSheet As Boolean

    Dim StrPrefix
    Dim strFileName As String
    Dim strFolderName As String

    'variant declaration needed for the Shell object to use a default directory
    Dim strDefaultFolder As Variant


 bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
    bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
    If Not bProcessFolder Then
        If Not bNewSheet Then
            MsgBox "There isn't much point creating a exact replica of your source file :)"
            Exit Sub
        End If
    End If

    'set default directory here if needed
    strDefaultFolder = "C:\temp"

    'If the user is collating all the sheets to a single target sheet then the row spacing
    'to distinguish between different sheets can be set here
    lrowSpace = 1

    If bProcessFolder Then
        strFolderName = BrowseForFolder(strDefaultFolder)
        'Look for xls, xlsx, xlsm files
        strFileName = Dir(strFolderName & "\*.xls*")
    Else
        strFileName = Application _
                      .GetOpenFilename("Select file to process (*.xls*), *.xls*")
    End If

    Set Wb1 = Workbooks.Add(1)
    Set ws1 = Wb1.Sheets(1)
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

    'Turn off screenupdating, events, alerts and set calculation to manual
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'set path outside the loop
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

    Do While Len(strFileName) > 0
        'Provide progress status to user
        Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
        'Open each workbook in the folder of interest
        Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
        If Not bNewSheet Then
            'add summary details to first sheet
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
        End If
        For Each ws2 In Wb2.Sheets
            If bNewSheet Then
                'All data to a single sheet
                'Skip importing target sheet data if the source sheet is blank
                Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

                If Not rng2 Is Nothing Then
                    Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                    'Find the first blank row on the target sheet
                    If Not rng1 Is Nothing Then
                        Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                        'Ensure that the row area in the target sheet won't be exceeded
                        If rng3.Rows.Count + rng1.Row < Rows.Count Then
                            'Copy the data from the used range of each source sheet to the first blank row
                            'of the target sheet, using the starting column address from the source sheet being copied
                            ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                        Else
                            MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                   "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                            Wb2.Close False
                            Exit Do
                        End If
                        'colour the first of any spacer rows
                        If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                    Else
                        'target sheet is empty so copy to first row
                        ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                    End If
                End If
            Else
                'new target sheet for each source sheet
                ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                'Remove any links in our target sheet
                With Wb1.Sheets(Wb1.Sheets.Count).Cells
                    .Copy
                    .PasteSpecial xlPasteValues
                End With
                On Error Resume Next
                Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                'sheet name already exists in target workbook
                If Err.Number <> 0 Then
                    'Add a number to the sheet name till a unique name is derived
                    Do
                        lSht = lSht + 1
                        Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                    Loop While Not ws3 Is Nothing
                    lSht = 0
                End If
                On Error GoTo 0
            End If
        Next ws2
        'Close the opened workbook
        Wb2.Close False
        'Check whether to force a DO loop exit if processing a single file
        If bProcessFolder = False Then Exit Do
        strFileName = Dir
    Loop

    'Remove any links if the user has used a target sheet
    If bNewSheet Then
        With ws1.UsedRange
            .Copy
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).Activate
        End With
    Else
        'Format the summary sheet if the user has created separate target sheets
        ws1.Activate
        ws1.Range("A1:B1").Font.Bold = True
        ws1.Columns.AutoFit
    End If

    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .StatusBar = vbNullString
    End With
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

    Dim ShellApp As Object
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

这篇关于从多个Excel提取数据到Main Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！