Question

说明：我想做的是允许用户通过浏览选择excel文件，然后将数据从表3复制到所选文件中，然后粘贴到当前工作簿sheet2（名称为Raw data（STEP 1））。从当前工作簿sheet2的结果中，我想将数据复制到一个新的工作表中，并希望根据其文件名而不是完整字符串而是仅以M 100P 1等结尾来重命名工作表。

我的文件名示例（只是一个虚拟文件），其中包含将近20个文件：

abcd_19-10-10_17-26_efgh-ijkl-02_ww1_line0_M 100P 1
abcd_19-10-10_18-33_efgh-ijkl-02_ww1_line0_M 100P 16

目前，我正在使用inputbox重命名工作表，如下所示：

Private Sub OpenWorkBook_Click()

Dim myFile As Variant
Dim OpenBook As Workbook

Application.ScreenUpdating = False

myFile = Application.GetOpenFilename(Title:="Browse your file", FileFilter:="Excel Files(*.xls*),*xls*")
If myFile <> False Then
    Set OpenBook = Application.Workbooks.Open(myFile)
    OpenBook.Sheets(3).Range("A2:R3063").Copy
    ThisWorkbook.Worksheets("Raw data(STEP 1)").Range("A3").PasteSpecial xlPasteValues
    OpenBook.Close True

    ThisWorkbook.Sheets(3).Range("A9:O27").Copy
    myVal = InputBox("Enter Sheet Name")
    Sheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
    ActiveSheet.Name = myVal
    ThisWorkbook.ActiveSheet.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
    ThisWorkbook.ActiveSheet.Range("A1").PasteSpecial xlPasteValues
    ThisWorkbook.ActiveSheet.Range("A1:O19").ColumnWidth = 10.8

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End If

End Sub

修改后的代码

If myFile <> False Then
    Set OpenBook = Application.Workbooks.Open(myFile)
    OpenBook.Sheets(3).Range("A2:R3063").Copy
    WB.Worksheets(2).Range("A3").PasteSpecial xlPasteValues
    OpenBook.Close True

    WB.Sheets(3).Range("A9:O27").Copy

    With WB
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = myVal = Split(WB.Name, ".")(0)
    .ActiveSheet.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
    .ActiveSheet.Range("A1").PasteSpecial xlPasteValues
    .ActiveSheet.Range("A1:O19").ColumnWidth = 10.8
    End With


    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End If

有没有不用输入框就能做到这一点？

任何帮助将不胜感激

Answer 1

要在末尾添加工作表并一次性命名，请尝试以下操作：

Thisworkbook.Sheets.Add(After:=Thisworkbook.Sheets(Thisworkbook.Sheets.Count)).Name = "Your sheet name goes here"

根据您的最后一个问题，我还提到最好设置一个工作簿对象并引用该对象：

Dim wb as Workbook: Set wb = ThisWorkbook

这将使上面的代码更加清晰：

With wb
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Your sheet name goes here"
End with

要更进一步并获得您当前的工作簿名称，您可以使用：

myVal = wb.Name 'Will get you with extension
myVal = Split(wb.Name, ".")(0) 'Will get you name without extension

并且如评论中所述，您还可以实现某种计数器。但是按照您当前的代码，没有循环可以这样做。以上内容归结为：

Dim wb as Workbook: Set wb = ThisWorkbook

With wb
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = Split(wb.Name, ".")(0) & "Your counter goes here"
End with

在旁注（也根据您的最后一个问题），在this上有关SO的文章中开始大幅度地改进代码。

Answer 2

感谢@JvdV，我对代码进行了修改，将其升级为

    Dim wbk, twb As Workbook, sPath As String, sFile As String, sName As String

    sPath = "C:\Users\mazman\Desktop\Hilmi\data Summary\"
    sFile = Dir(sPath & "*.xls*")

    Set twb = ThisWorkbook
    Application.ScreenUpdating = 0

    Do While sFile <> ""
        Set wbk = Workbooks.Open(sPath & sFile)

        With wbk
            sName = Split(Split(.Name, "_")(6), ".")(0)
            .Sheets(3).Copy after:=twb.Sheets(twb.Sheets.Count)
            .Close 0
        End With

        With twb
        .ActiveSheet.Name = sName
        .ActiveSheet.Range("A1:R1").RowHeight = 45
        .ActiveSheet.Range("A1:R1").WrapText = True
        .ActiveSheet.Range("A1:R1").Interior.ColorIndex = 15
        End With
        sFile = Dir()
    Loop
    Set wbk = Nothing

使用文件名重命名工作表

2 个答案: