我有 65 个工作簿，每个工作簿中有一个工作表。我需要将所有 65 个工作簿合并为一本工作簿，并将所有相应的工作簿作为新工作簿中的 65 个工作表。我需要将所有 65 个工作簿名称保留为新的单个工作簿中的工作表名称。
到目前为止，我在网上找到了一个代码来执行此操作，但该代码要求所有要合并的工作簿都需要打开。有没有办法修改此代码，以便不需要打开所有工作簿？我可以只引用(文件夹)驱动器上的某个位置吗？
感谢您的帮助!
这是代码:
Option Explicit
Public u_sheets As String
Sub Consolidate()
Dim ws As Worksheet
Dim wb As Workbook, NewBook As Workbook
Dim scount As Integer
Dim NewWS As Worksheet
Dim wsSheet As Worksheet
Dim i As Integer
Dim NextName As String
Dim sl As Integer
Dim newfilepath As String
newfilepath = ""
Dim first_only As Boolean
first_only = False
Call init
'are we doing the first sheet only?
If u_sheets = "First Sheet Only" Then first_only = True
'Setup
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Create new workbook for merged sheets
newfilepath = ThisWorkbook.Path & "\Merged" 'excel will auto append the appropriate extension (xlsx)
Set NewBook = Workbooks.Add
NewBook.SaveAs Filename:=newfilepath
i = 1
'Loop through each open workbook
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name And wb.Name <> NewBook.Name And Left(wb.Name, 8) <> "PERSONAL" Then
Dim x As String
'Get name of this workbook
x = JustText(Left(wb.Name, Len(wb.Name) - 4))
'count sheets in this workbook
If first_only Then
scount = 1
Else
scount = wb.Sheets.Count
End If
'Loop through each sheet in Workbook
For Each ws In wb.Worksheets
'do some naming conventions
Dim xy As String
Dim y As String
y = JustText(ws.Name) 'strip out all characters from name
If scount > 1 Then
xy = x + y
Else
xy = x
End If
'check the length of the new name and shorten if needed
sl = Len(xy)
If sl > 30 Then
xy = Right(x, sl - (sl - 30))
End If
'copy worksheet to new workbook
ws.Copy After:=NewBook.Worksheets(NewBook.Worksheets.Count)
'rename worksheet
NewBook.Worksheets(NewBook.Worksheets.Count).Name = xy
If scount = 1 Then Exit For 'break out of loop if we are only doing one sheet
Next
End If
Next
'remove all original worksheets
'NewBook.Worksheets("Sheet1").Delete
'NewBook.Worksheets("Sheet2").Delete
'NewBook.Worksheets("Sheet3").Delete
ErrorExit: 'Cleanup
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
Private Function JustText(text_to_clean As String, Optional upper As Boolean = False)
'removes all characters except for letters and numbers
'where
'text_to_clean is the text to clean
'upper boolean will return UPPER case if true; false if omitted
'declare and initialize user variables
Dim method As Integer
'choices:
'1=remove everything except what is in the leave_these variable
'2=leave everything except what is specifically removed from the "leave" section
method = 1
Dim leave_these As String 'only used if method=1
leave_these = "A-Za-z0-9" 'if you want to allow a space "A-Za-z0-9 "
'declare and initialize system variables
Dim temp As String
temp = text_to_clean
'method
Select Case method
Case 1 'remove everything except what is in the leave_these variable
Dim x As String, y As String, z As String, i As Long
x = temp
For i = 1 To Len(x)
y = Mid(x, i, 1)
If y Like "[" & leave_these & "]" Then z = z & y
Next i
temp = z
Case 2 'leave everything except characters below
'feel free to comment out the lines for items you do not wish to remove, or add new lines as desired
temp = Replace(temp, ",", "") 'remove commas
temp = Replace(temp, " ", "") 'remove spaces
temp = Replace(temp, "-", "") 'remove dashes
temp = Replace(temp, ":", "") 'remove colon
temp = Replace(temp, ";", "") 'remove semi-colon
End Select
If upper Then JustText = UCase(temp) Else JustText = temp
End Function
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
Private Sub init()
'initialize all public variables
u_sheets = Range("u_sheets")
End Sub
最佳答案
此代码(之前托管在另一个论坛上)提供了三个选项:
- 将单个文件夹中所有 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
关于excel - 将多个工作簿合并为一个工作簿，并将所有工作簿作为工作表，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/15648118/