VBA move file, copy sheet, then delete it

[Dao Ha Quang]

Sub CopySheet()

FileName = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="OPEN FILE", MultiSelect:=False)
Set closedBook = Workbooks.Open(FileName)
closedBook.Sheets("Sheets1").Move Before:=ThisWorkbook.Sheets("Sheets2")
closedBook.Close SaveChanges:=False
If FileName = False Then Exit Sub

End Sub

Hello
I use this VBA to select open excel file then Copy "Sheets1" to current excel file.
But there is a problem that if the opened excel file is in a folder with name have special character, it will get the error "Path error / file access error: '.\VBxxx.tmp"
I have the idea to copy the File containing "Sheets1" to the Desktop, then copy "Sheets1" to the current excel file, then delete the file on the Desktop. But I don't know how to do that. Help me

 

[Herakles]

Try this.

It copies the selected file to the active workbook folder and then deletes it afterwards.
It assumes that a file by the same name does not already exist in this folder.

It does not check that the required worksheets exist but it will throw up an error if they do not.

Public Sub subCopyWorksheet()
Dim strFileName As Variant
Dim oFSO As Object
Dim Wb As Workbook

On Error GoTo Err_Handler

    ActiveWorkbook.Save
    
    Set Wb = ActiveWorkbook
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    strFileName = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="OPEN FILE", MultiSelect:=False)
    
    If strFileName = False Then
        Exit Sub
    End If
            
    oFSO.CopyFile strFileName, ActiveWorkbook.Path & "\"
    
    strFileName = Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
        
    Workbooks.Open FileName:=ActiveWorkbook.Path & "\" & _
        Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
        
    ActiveWorkbook.Worksheets("Sheets1").Copy before:=Wb.Sheets("Sheets2")
                
    Workbooks(strFileName).Close SaveChanges:=True
    
    Kill ActiveWorkbook.Path & "\" & strFileName

Exit_Handler:

    Exit Sub

Err_Handler:

    MsgBox "There has been an error.", vbInformation, "Warning!"
    
    Resume Exit_Handler
    
End Sub

 

[Dao Ha Quang]

Try this.

It copies the selected file to the active workbook folder and then deletes it afterwards.
It assumes that a file by the same name does not already exist in this folder.

It does not check that the required worksheets exist but it will throw up an error if they do not.

Public Sub subCopyWorksheet()
Dim strFileName As Variant
Dim oFSO As Object
Dim Wb As Workbook

On Error GoTo Err_Handler

    ActiveWorkbook.Save
   
    Set Wb = ActiveWorkbook
   
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    strFileName = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="OPEN FILE", MultiSelect:=False)
   
    If strFileName = False Then
        Exit Sub
    End If
           
    oFSO.CopyFile strFileName, ActiveWorkbook.Path & "\"
   
    strFileName = Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
       
    Workbooks.Open FileName:=ActiveWorkbook.Path & "\" & _
        Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
       
    ActiveWorkbook.Worksheets("Sheets1").Copy before:=Wb.Sheets("Sheets2")
               
    Workbooks(strFileName).Close SaveChanges:=True
   
    Kill ActiveWorkbook.Path & "\" & strFileName

Exit_Handler:

    Exit Sub

Err_Handler:

    MsgBox "There has been an error.", vbInformation, "Warning!"
   
    Resume Exit_Handler
   
End Sub

Thank you. This seems very good, but if the folder active workbook file has special characters, it still seems to be error,
Because this file has many users and they are not professional.
I want to copy in to the Desktop to make sure the error won't happen

 

[Herakles]

This will copy it temporarily to the Desktop folder.

Public Sub subCopyWorksheet()
Dim strFileName As Variant
Dim oFSO As Object
Dim Wb As Workbook
Dim strDesktopPath As String

On Error GoTo Err_Handler

    ActiveWorkbook.Save
    
    strDesktopPath = fncGetDesktop
        
    Set Wb = ActiveWorkbook
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    strFileName = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="OPEN FILE", MultiSelect:=False)
    
    If strFileName = False Then
        Exit Sub
    End If
    
    ' Copy file to Desktop.
    oFSO.CopyFile strFileName, strDesktopPath & "\"
        
    strFileName = Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
        
    Workbooks.Open FileName:=strDesktopPath & "\" & _
        Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
        
    ActiveWorkbook.Worksheets("Sheets1").Copy before:=Wb.Sheets("Sheets2")
                
    Workbooks(strFileName).Close SaveChanges:=True
    
    Kill strDesktopPath & "\" & strFileName

Exit_Handler:

    Exit Sub

Err_Handler:

    MsgBox "There has been an error.", vbInformation, "Warning!"
    
    Resume Exit_Handler
    
End Sub

Public Function fncGetDesktop() As String
Dim oWSHShell As Object

    Set oWSHShell = CreateObject("WScript.Shell")
    fncGetDesktop = oWSHShell.SpecialFolders("Desktop")
    Set oWSHShell = Nothing

End Function

 

[Dao Ha Quang]

This will copy it temporarily to the Desktop folder.

Public Sub subCopyWorksheet()
Dim strFileName As Variant
Dim oFSO As Object
Dim Wb As Workbook
Dim strDesktopPath As String

On Error GoTo Err_Handler

    ActiveWorkbook.Save
  
    strDesktopPath = fncGetDesktop
      
    Set Wb = ActiveWorkbook
  
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    strFileName = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="OPEN FILE", MultiSelect:=False)
  
    If strFileName = False Then
        Exit Sub
    End If
  
    ' Copy file to Desktop.
    oFSO.CopyFile strFileName, strDesktopPath & "\"
      
    strFileName = Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
      
    Workbooks.Open FileName:=strDesktopPath & "\" & _
        Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1)
      
    ActiveWorkbook.Worksheets("Sheets1").Copy before:=Wb.Sheets("Sheets2")
              
    Workbooks(strFileName).Close SaveChanges:=True
  
    Kill strDesktopPath & "\" & strFileName

Exit_Handler:

    Exit Sub

Err_Handler:

    MsgBox "There has been an error.", vbInformation, "Warning!"
  
    Resume Exit_Handler
  
End Sub

Public Function fncGetDesktop() As String
Dim oWSHShell As Object

    Set oWSHShell = CreateObject("WScript.Shell")
    fncGetDesktop = oWSHShell.SpecialFolders("Desktop")
    Set oWSHShell = Nothing

End Function

Thank you
However, I would like to add one more thing. After the "There has been an error". I want to close and delete the copied file to the Desktop

 

[Herakles]

Do you get the "There has been an error" message?

The following line should delete the copied file.

Kill strDesktopPath & "\" & strFileName

 

[Dao Ha Quang]

Do you get the "There has been an error" message?

The following line should delete the copied file.

Kill strDesktopPath & "\" & strFileName

This doesn't seem to work
When the worksheet to be copied does not exist, VBA will give an error and it will open the copied workbook to the Desktop.
I want when it error, it CLOSE and DELETE that copied workbook

 

[Dao Ha Quang]

https://img.upanh.tv/2023/05/12/Animation.gif