使用他们的文件名重命名 sheet

Question

描述：我想做的是允许用户通过浏览 select excel 文件，然后将数据从 sheet 3 复制到 selected 文件并粘贴到当前工作簿 sheet2（名称为 Raw data(STEP 1) ）。根据当前工作簿 sheet2 中的结果，我想将数据复制到新的 sheet 并希望根据文件名而不是完整字符串重命名 sheet结尾如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

现在我正在使用输入框重命名 sheet，如下面的代码：

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

要在末尾添加 sheet 并一次性命名，请尝试这样的操作：

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 post 上的 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

使用他们的文件名重命名 sheet

Rename sheet using their file name

excel

vba

rename

worksheet