【发布时间】：2013-03-26 21:54:46
【问题描述】：
我有 65 个工作簿，每个工作簿中有一个工作表。我需要将所有 65 个工作簿合并为一个工作簿，并将所有相应的工作簿作为新工作簿中的 65 个工作表。我需要将所有 65 个工作簿名称保留为新 SINGLE 工作簿中的工作表名称。
到目前为止，我在网上找到了一个代码来执行此操作，但此代码要求所有将要合并的工作簿都需要打开。有没有办法修改此代码，以便不需要打开所有工作簿？我可以只引用（文件夹）我驱动器上的一个位置吗？
感谢您的帮助！
代码如下：
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-2010 vba