여러 통합 문서를 하나의 통합 문서로 병합 한 후 파일 이름을 기준으로 시트 이름 바꾸기

Question

나는 이것을 내 개인 일자리로 만들었습니다. Google에서 검색 한 후 여러 통합 문서 (각각 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