从多个Excel中获取数据到主Excel

2 回答

• 3

  来自我在EE上主持的文章Collating worksheets from one or more workbooks into a summary file

  此代码提供了三个选项来组合位于文件夹中的Excel文件：

  • 将单个文件夹中所有Excel工作簿中的所有工作表整理为单个摘要工作表

  • 将单个文件夹中所有Excel工作簿中的所有工作表整理为单个摘要工作簿

  • 将单个Excel工作簿中的所有工作表整理为单个摘要工作表

  选项（2）听起来像你想要的

  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
  

  回复于 2024-04-28T03:36:13+08:00
• 1

  a）它们被称为Excel文件或工作簿 - 表格是底部的标签...

  b）如果你有2007年去数据>从其他来源>从Microsoft查询> Excel文件*>选择1文件>选项>确保选中系统表选项=>现在你可以选择工作表，列，过滤器和排序顺序你需要 ：））

  回复于 2024-04-28T03:36:13+08:00