Excel 合并工作簿时如何重命名工作表？_Excel_Vba

Excel 合并工作簿时如何重命名工作表？

excel vba

Excel 合并工作簿时如何重命名工作表？,excel,vba,Excel,Vba,我需要从一个文件夹中合并工作簿，我发现下面的代码应该完全满足我的需要。代码来自我遇到的问题是，我的工作簿中的工作表都有相同的长标题，并且似乎会使子系统崩溃，因为excel由于冲突无法自动重命名工作表（例如，没有空间添加（2）和（3）等）如何在代码中添加任意名称的工作表，例如Copied1、copied2等 Sub MergeWorkbooks() Dim FolderName As String Dim directory As String, fileName As String Dim

我需要从一个文件夹中合并工作簿，我发现下面的代码应该完全满足我的需要。代码来自

我遇到的问题是，我的工作簿中的工作表都有相同的长标题，并且似乎会使子系统崩溃，因为excel由于冲突无法自动重命名工作表（例如，没有空间添加（2）和（3）等）

如何在代码中添加任意名称的工作表，例如Copied1、copied2等

Sub MergeWorkbooks()

Dim FolderName As String
Dim directory As String, fileName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet

Set wb1 = Workbooks.Add

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder."
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With

directory = FolderName & "\"
fileName = Dir(directory & "*.xls?")

Do While fileName <> ""
Set wb2 = Workbooks.Open(directory & fileName)
For Each ws In wb2.Sheets
    ws.Copy after:=wb1.Sheets(Sheets.Count)
Next ws
wb2.Close savechanges:=False
fileName = Dir
Loop

End Sub

子合并工作簿（）
Dim FolderName作为字符串
Dim目录为字符串，文件名为字符串
将wb1设置为工作簿，将wb2设置为工作簿
将ws设置为工作表
设置wb1=工作簿。添加
使用Application.FileDialog（msoFileDialogFolderPicker）
.Title=“请选择一个文件夹。”
.AllowMultiSelect=False
显示
出错时继续下一步
FolderName=.SelectedItems（1）
呃，明白了
错误转到0
以
directory=FolderName&“\”
fileName=Dir（目录&“*.xls？”）
文件名“”时执行此操作
设置wb2=Workbooks.Open（目录和文件名）
对于wb2.Sheets中的每个ws
ws.Copy after:=wb1.Sheets（Sheets.Count）
下一个ws
wb2.关闭保存更改：=False
fileName=Dir
环
端接头

在将工作表移动到另一本书之前，请使用变量

重命名工作表。

对应于循环中的纸张来源的书籍

因此，第五本书的页码名称为

Sheet1 5

，第六本书的页码名称为

Sheet1 6

，依此类推

Dim i尽可能长
i=1
文件名“”时执行此操作
设置wb2=Workbooks.Open（目录和文件名）
对于wb2.Sheets中的每个ws
ws.Name=ws.Name&Chr（32）&i'基于urderboy的响应，我添加了用户提示以选择是否需要批重命名，如果需要，则选择批名称。在需要的时候有选择是很好的
Sub MergeWorkbooks()

Dim FolderName As String
Dim directory As String, fileName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim iAnswer As VbMsgBoxResult
Dim xAppend As String

Set wb1 = Workbooks.Add

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder."
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With

directory = FolderName & "\"
fileName = Dir(directory & "*.xls?")

'Prompt user to decide if batch rename is required
iAnswer = MsgBox("Would you like to batch rename the worksheets?", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")

    'vbYes: Rename Worksheets
    If iAnswer = vbYes Then

1:

        xAppend = InputBox(Prompt:= _
                    "Enter new batch name for worksheets." _
                    & vbNewLine & vbNewLine & _
                    "Sheets will be appended with number based on the order in which they are copied." _
                    & vbNewLine & vbNewLine & _
                    "If 'Cancel' is selected, worksheets will be renamed as number only, based on order in which they are copied.", _
                    Title:="Naming Convention")

                        If InStr(xAppend, "<") > 0 _
                            Or InStr(xAppend, ">") > 0 _
                            Or InStr(xAppend, ":") > 0 _
                            Or InStr(xAppend, Chr(34)) > 0 _
                            Or InStr(xAppend, "/") > 0 _
                            Or InStr(xAppend, "\") > 0 _
                            Or InStr(xAppend, "|") > 0 _
                            Or InStr(xAppend, "?") > 0 _
                            Or InStr(xAppend, "*") > 0 _
                                 Then
                                    MsgBox "Suggested filename contains an invalid character"
                                    GoTo 1
                        End If

            Dim i As Long
            i = 1

            Do While fileName <> ""
                Set wb2 = Workbooks.Open(directory & fileName)
                    For Each ws In wb2.Sheets
                        ws.Name = xAppend & i                       '<-- Rename
                        ws.Copy after:=wb1.Sheets(Sheets.Count)
                    Next ws
                wb2.Close savechanges:=False
                fileName = Dir
                i = i + 1                                            '<-- Increment i for next bok
            Loop


        'vbNo: Rename Worksheets
        ElseIf iAnswer = vbNo Then

            Do While fileName <> ""
                Set wb2 = Workbooks.Open(directory & fileName)
                    For Each ws In wb2.Sheets
                        ws.Copy after:=wb1.Sheets(Sheets.Count)
                Next ws
            wb2.Close savechanges:=False
            fileName = Dir
            Loop

        'vb Canel: Exit
        Else
            Exit Sub

    End If

End Sub

子合并工作簿（）
Dim FolderName作为字符串
Dim目录为字符串，文件名为字符串
将wb1设置为工作簿，将wb2设置为工作簿
将ws设置为工作表
Dim iAnswer作为VbMsgBoxResult
以字符串的形式出现
设置wb1=工作簿。添加
使用Application.FileDialog（msoFileDialogFolderPicker）
.Title=“请选择一个文件夹。”
.AllowMultiSelect=False
显示
出错时继续下一步
FolderName=.SelectedItems（1）
呃，明白了
错误转到0
以
directory=FolderName&“\”
fileName=Dir（目录&“*.xls？”）
'提示用户决定是否需要批量重命名
iAnswer=MsgBox（“是否要批量重命名工作表？”，vbYesNoCancel+VBQUEST+vbDefaultButton1，“对工作表排序”）
'vbYes:重命名工作表
如果iAnswer=vbYes，则
1:
xAppend=InputBox（提示：=_
“输入工作表的新批处理名称。”_
&vbNewLine&vbNewLine&_
“工作表将根据复制顺序追加编号。”_
&vbNewLine&vbNewLine&_
“如果选择“取消”，工作表将根据复制顺序重命名为“仅编号”。”_
标题：=“命名约定”）
如果InStr（xAppend，“”）大于0_
或InStr（xAppend，“：”）>0_
或仪表（xAppend，Chr（34））>0_
或仪表（X形，“/”）大于0_
或InStr（xAppend，“\”）>0_
或InStr（xAppend，“|”）大于0_
或仪表（X形，“？”）大于0_
或仪表（X形，“*”）大于0_
然后
MsgBox“建议的文件名包含无效字符”
转到1
如果结束
我想我会坚持多久
i=1
文件名“”时执行此操作
设置wb2=Workbooks.Open（目录和文件名）
对于wb2.Sheets中的每个ws
ws.Name=xAppend&i'为什么不在复制它们之前重命名它们呢？所以在ws.copy
之前做一个ws.Name=谢谢！我曾经想过我需要做一个嵌套循环，但是现在我看到我可以在do While Filename“”循环中递增。比我想象的要简单得多。终于有机会尝试了，是的，效果非常好。
Sub MergeWorkbooks()

Dim FolderName As String
Dim directory As String, fileName As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim iAnswer As VbMsgBoxResult
Dim xAppend As String

Set wb1 = Workbooks.Add

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder."
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    FolderName = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With

directory = FolderName & "\"
fileName = Dir(directory & "*.xls?")

'Prompt user to decide if batch rename is required
iAnswer = MsgBox("Would you like to batch rename the worksheets?", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")

    'vbYes: Rename Worksheets
    If iAnswer = vbYes Then

1:

        xAppend = InputBox(Prompt:= _
                    "Enter new batch name for worksheets." _
                    & vbNewLine & vbNewLine & _
                    "Sheets will be appended with number based on the order in which they are copied." _
                    & vbNewLine & vbNewLine & _
                    "If 'Cancel' is selected, worksheets will be renamed as number only, based on order in which they are copied.", _
                    Title:="Naming Convention")

                        If InStr(xAppend, "<") > 0 _
                            Or InStr(xAppend, ">") > 0 _
                            Or InStr(xAppend, ":") > 0 _
                            Or InStr(xAppend, Chr(34)) > 0 _
                            Or InStr(xAppend, "/") > 0 _
                            Or InStr(xAppend, "\") > 0 _
                            Or InStr(xAppend, "|") > 0 _
                            Or InStr(xAppend, "?") > 0 _
                            Or InStr(xAppend, "*") > 0 _
                                 Then
                                    MsgBox "Suggested filename contains an invalid character"
                                    GoTo 1
                        End If

            Dim i As Long
            i = 1

            Do While fileName <> ""
                Set wb2 = Workbooks.Open(directory & fileName)
                    For Each ws In wb2.Sheets
                        ws.Name = xAppend & i                       '<-- Rename
                        ws.Copy after:=wb1.Sheets(Sheets.Count)
                    Next ws
                wb2.Close savechanges:=False
                fileName = Dir
                i = i + 1                                            '<-- Increment i for next bok
            Loop


        'vbNo: Rename Worksheets
        ElseIf iAnswer = vbNo Then

            Do While fileName <> ""
                Set wb2 = Workbooks.Open(directory & fileName)
                    For Each ws In wb2.Sheets
                        ws.Copy after:=wb1.Sheets(Sheets.Count)
                Next ws
            wb2.Close savechanges:=False
            fileName = Dir
            Loop

        'vb Canel: Exit
        Else
            Exit Sub

    End If

End Sub