複数のワークブックを1つのワークブックにマージした後に、ファイル名に基づいてシートの名前を変更します。

Question

私は個人的な仕事のためにこれを作成しました。 Googleで検索した後、複数のワークブック（それぞれ1つのワークシートがある）を1つのワークブックにマージするコードが見つかりました。そして、これらのワークシートは、それが "shXetnaXe" と呼ぶ同じ名前を持っているので、私はワークブックを選択しようとすると、それは

"shXetnaXe" for sheet(1)

"shXetnaXe(1)" for sheet(2)

"shXetnaXe(2)" for sheet(3)

終わりました等々。

私はそれらの元の名前、それらのシートは自動的に元の選択ワークブックの名前 という名前にしたいのです：「9月1日」「9月2日」「9月3日」 、私はそれを少し変更してみましたが、それは常に失敗します。

ここでの問題はopenfiles.nameは、ファイルの完全なファイルパスと名前を返すことで、コード

`Sub opensheets() 
Dim openfiles 
Dim crntfile As Workbook 
Set crntfile = Application.ActiveWorkbook 
Dim x As Integer 
On Error GoTo ErrHandler 
Application.ScreenUpdating = False 
openfiles = Application.GetOpenFilename _ 
(FileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", _ 
MultiSelect:=True, Title:="Select Excel file to merge!") 

If TypeName(openfiles) = "Boolean" Then 
    MsgBox "You need to select atleast one file" 
    GoTo ExitHandler 
End If 

x = 1 
While x <= UBound(openfiles) 
    Workbooks.Open Filename:=openfiles(x) 
    Sheets().Move After:=crntfile.Sheets(crntfile.Sheets.Count) 
    Set rnmsht = Workbook.Open 
    Sheets(openfiles) = rnmsht 

    Before:=ActiveWorkbook.Sheets(openfiles.name) 
    x = x + 1 
Wend 


Application.DisplayAlerts = False 
Sheets(1).Select 
ActiveWindow.SelectedSheets.Delete 


ExitHandler: 
Application.ScreenUpdating = True 
Exit Sub 

ErrHandler: 
MsgBox Err.Description 
Resume ExitHandler 
End Sub' 

Answer 1

コードをいくつか変更しました。これらの変更の一部を非常に簡単に元に戻すことができます。

Sub opensheets() 
    Dim openfiles 
    Dim crntfile As Workbook 
    Set crntfile = Application.ActiveWorkbook 
    Dim targetWkbk As Workbook 
    Dim newName As String 
    Dim x As Integer 
    On Error GoTo ErrHandler 
    Application.ScreenUpdating = False 
    openfiles = Application.GetOpenFilename _ 
       (FileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", _ 
       MultiSelect:=True, Title:="Select Excel file to merge!") 

    If TypeName(openfiles) = "Boolean" Then 
     MsgBox "You need to select atleast one file" 
     GoTo ExitHandler 
    End If 

    With crntfile 
    x = 1 
    While x <= UBound(openfiles) 
     Set targetWkbk = Workbooks.Open(Filename:=openfiles(x)) 
     newName = targetWkbk.Name 
     'you need this part if there are several (more than 1) worksheets 
     'in your workbook, this might come in handy for later purposes 
     'however, if it is always just one worksheet, delete the following parts 
     'Line: For i = 1.. 
     'Line: Next 
     'part & " Sheet " & i 
     For i = 1 To targetWkbk.Sheets.Count 
      targetWkbk.Worksheets(i).Copy After:=.Sheets(.Sheets.Count) 
      .Worksheets(.Sheets.Count).Name = newName & " Sheet " & i 
     Next 
     targetWkbk.Close 
     x = x + 1 
    Wend 
    End With 
ExitHandler: 
    Application.ScreenUpdating = True 
    Exit Sub 

ErrHandler: 
    MsgBox Err.Description 
    Resume ExitHandler 
End Sub 

私はそれは、現在のファイルの最初のワークシートを削除し、この部分に

Application.DisplayAlerts = False 
Sheets(1).Select 
ActiveWindow.SelectedSheets.Delete 

を削除しました。これが意図されているかどうかはわかりませんでした。その場合は、バックラインがエラーをスロー

crntfile.Worksheets(1).Delete 

HTH

Answer 2

です。特定の特殊文字を含むワークシートに名前を付けることはできません。 /、\または：

Sub opensheets() 
    Dim openfiles 
    Dim xlWB As Workbook 
    Dim NewSheetName as String 
    Dim x As Integer 
    On Error GoTo ErrHandler 
    Application.ScreenUpdating = False 
    openfiles = Application.GetOpenFilename _ 
       (FileFilter:="Microsoft Excel Files (*.xls;*.xlsx),*.xls;*.xlsx", _ 
       MultiSelect:=True, Title:="Select Excel file to merge!") 

    If TypeName(openfiles) = "Boolean" Then 
     MsgBox "You need to select atleast one file" 
     GoTo ExitHandler 
    End If 

    x = 1 
    While x <= UBound(openfiles) 
     Set xlWB = Workbooks.Open(Filename:=openfiles(x)) 
     NewSheetName = xlWB.Name 
     xlWB.Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 
     ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = NewSheetName 

     x = x + 1 
    Wend 


' Application.DisplayAlerts = False 
' Sheets(1).Select 
' ActiveWindow.SelectedSheets.Delete 


ExitHandler: 
    Application.ScreenUpdating = True 
    Exit Sub 

ErrHandler: 
    MsgBox Err.Description 
    Resume ExitHandler 
End Sub