Move sheet from one file to another in the same folder

[iamafreak]

Hello Everyone.

I have a folder with some file sets in it. Something like this:

12_500 07-02-2017#01.xls
12_500 07-02-2017.xls
12_501 07-02-2017#01.xls
12_501 07-02-2017.xls
12_502 07-02-2017#01.xls
12_502 07-02-2017.xls
12_503 07-02-2017#01.xls
12_503 07-02-2017.xls

I would like to merge them. That is, move the sheets from file ending with #01 to the file ending with 07-02-2017

For example, move sheets from:
12_500 07-02-2017#01.xls to 12_500 07-02-2017.xls
12_501 07-02-2017#01.xls to 12_501 07-02-2017.xls

and so on. In the end only these files should remain:

12_500 07-02-2017.xls
12_501 07-02-2017.xls
12_502 07-02-2017.xls
12_503 07-02-2017.xls

The files ending with #01 should be deleted.

It would be great if someone can provide a vba that can do this for me.

Thanks a bunch.

 

[iamafreak]

Bump (apologies)

 

[GTO]

Added/moved AFTER the existing or BEFORE the existing sheets?

 

[iamafreak]

It doesn't matter. Can be after or before. Thanks.

 

[GTO]

The workbook with the code would go in the folder immediately above the folder the workbooks are in.

Absolutely test on some temp created junk workbooks first

In a Standard Module:

Option Explicit
  
' 12_500 07-02-2017#01.xls
' 12_500 07-02-2017.xls
  
Sub example01()
Const FOLDER_NAME = "\New folder\"
  
Dim FSO           As Object ' Scripting.FileSystemObject
Dim fsoFile       As Object ' Scripting.File
Dim fsoFolder     As Object ' Scripting.Folder
Dim REX           As Object ' VBScript_RegExp_55.RegExp
  
Dim wbSource      As Workbook
Dim wbDestination As Workbook
Dim wks           As Worksheet
  
Dim arrNames()    As String
Dim n             As Long
Dim i             As Long
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set REX = CreateObject("VBScript.RegExp")
  
  
  On Error Resume Next
  Set fsoFolder = FSO.GetFolder(ThisWorkbook.Path & FOLDER_NAME)
  On Error GoTo 0
  
  If fsoFolder Is Nothing Then
    MsgBox "Bad folder"
    Exit Sub
  End If
  
  With REX
    .Global = False
    .IgnoreCase = True
    .Pattern = "[0-9]{2}\ {1,2}[0-9]{2}\-[0-9]{2}\-[0-9]{4}\.xls"
  End With
  
  ReDim arrNames(1 To fsoFolder.Files.Count)
  
  For Each fsoFile In fsoFolder.Files
    If REX.Test(fsoFile.Name) Then
      n = n + 1
      arrNames(n) = fsoFile.Name
    End If
  Next
  
  ReDim Preserve arrNames(1 To n)
  
  Application.EnableEvents = False
  
  For n = 1 To UBound(arrNames)
    
    If FSO.FileExists(ThisWorkbook.Path & FOLDER_NAME & Left$(arrNames(n), Len(arrNames(n)) - 4) & "#01.xls") Then
      
      Set wbSource = Workbooks.Open(ThisWorkbook.Path & FOLDER_NAME & Left$(arrNames(n), Len(arrNames(n)) - 4) & "#01.xls", , True)
      Set wbDestination = Workbooks.Open(ThisWorkbook.Path & FOLDER_NAME & arrNames(n))
      
      'Tack in a sheet so we can move all pre-existing sheets
      wbSource.Worksheets.Add wbSource.Worksheets(1)
      
      Do While wbSource.Worksheets.Count >= 2
        wbSource.Worksheets(2).Move After:=wbDestination.Worksheets(wbDestination.Worksheets.Count)
      Loop
      
      wbSource.Close False
      Kill ThisWorkbook.Path & FOLDER_NAME & Left$(arrNames(n), Len(arrNames(n)) - 4) & "#01.xls"
      DoEvents
      wbDestination.Close True
      
    End If
  Next
  
  Application.EnableEvents = True
  
End Sub

Hope that helps,

Mark

PS. Change "New folder" to the folder's name that the workbook's are in

 

[GTO]

Sorry, change the Pattern to:

    .Pattern = "[0-9]{2}\_[0-9]{3}\ {1,2}[0-9]{2}\-[0-9]{2}\-[0-9]{4}\.xls"

 

[iamafreak]

Thanks a lot GTO. The first code you posted works fine. However, when I try to include it another file with some macros in it, it fails with Bad folder pop up.
But it runs fine, when I copy the code to a new workbook. Any idea?

 

[GTO]

Thanks a lot GTO. The first code you posted works fine.

I would still suggest including the second pattern, it is better.

However, when I try to include it another file with some macros in it, it fails with Bad folder pop up.
But it runs fine, when I copy the code to a new workbook. Any idea?

It was meant for a workbook in the folder immediately above the folder the files are in. If there is other code in the workbook you inserted my suggestion in, I would have no idea without seeing the code.

Hope that helps,

Mark

 

[iamafreak]

I would still suggest including the second pattern, it is better.



It was meant for a workbook in the folder immediately above the folder the files are in. If there is other code in the workbook you inserted my suggestion in, I would have no idea without seeing the code.

Hope that helps,

Mark

Great.. That explains. I had the whole path name instead of the Folder name. Works perfectly now. Thanks a lot once again.

When I use the new pattern, I get the following message "Subscript out of range"

 

[GTO]

Great.. That explains. I had the whole path name instead of the Folder name. Works perfectly now. Thanks a lot once again.

When I use the new pattern, I get the following message "Subscript out of range"

That should not be. Not re-tested (I already had before posting the original code); see if this works. If you get the same error, please note on what line the error occurs.

Option Explicit


' 12_500 07-02-2017#01.xls
' 12_500 07-02-2017.xls
  
Sub example01()
Const FOLDER_NAME = "\New folder\"
  
Dim FSO           As Object ' Scripting.FileSystemObject
Dim fsoFile       As Object ' Scripting.File
Dim fsoFolder     As Object ' Scripting.Folder
Dim REX           As Object ' VBScript_RegExp_55.RegExp
  
Dim wbSource      As Workbook
Dim wbDestination As Workbook
Dim wks           As Worksheet
  
Dim arrNames()    As String
Dim n             As Long
Dim i             As Long
  
  ' Create references to new instances of the FileSystemObject Object and Rex Object
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set REX = CreateObject("VBScript.RegExp")
  
  
  ' Ensure the named folder is a sub-folder in the folder ThisWorkbook resides in...
  On Error Resume Next
  Set fsoFolder = FSO.GetFolder(ThisWorkbook.Path & FOLDER_NAME)
  On Error GoTo 0
  
  ' ...or bail out!
  If fsoFolder Is Nothing Then
    MsgBox "Bad folder"
    Exit Sub
  End If
  
  
  With REX
    ' The pattern will be aimed at confirming each individual filename like: '12_500 07-02-2017.xls' so Global is False as we want to test
    ' for a match against the entire filename
    .Global = False
    ' In case someone saves a file as '12_500 07-02-2017.XLS' for example
    .IgnoreCase = True
    ' This pattern matches 2-digits, followed by (FB) 1 to 2 spaces, FB 2-digits, FB a hyphen, FB 2-digits, FB a hyphen, FB 4-digits, FB '.xls'.
    ' As I did not insist on the match requiring start and end string markers (which I probably should have), this means that the actual match
    ' for '12_500 07-02-2017.xls' would be '00 07-02-2017.xls' (OOPS on my part)
    '.Pattern = "[0-9]{2}\ {1,2}[0-9]{2}\-[0-9]{2}\-[0-9]{4}\.xls"
    ' Sooo... the updated pattern includes looking for the underscore and the '500' and would match '12_500 07-02-2017.xls'
    'BUT... this would also match 'ACK 12_500 07-02-2017.xls' , so here's better yet I believe, as we'll include the start/end string markers
    .Pattern = "^[0-9]{2}\_[0-9]{3}\ {1,2}[0-9]{2}\-[0-9]{2}\-[0-9]{4}\.xls$"
  End With
  
  ' Oversize an array simply based on the max number of possibly matching filenames, that is, the number of files in the subfolder
  ReDim arrNames(1 To fsoFolder.Files.Count)
  
  ' Then populate the array and track how many matches we found
  For Each fsoFile In fsoFolder.Files
    If REX.Test(fsoFile.Name) Then
      n = n + 1
      arrNames(n) = fsoFile.Name
    End If
  Next
  
  ' Then trim the array
  ReDim Preserve arrNames(1 To n)
  
  
  'The rest is self explanatory I believe, but please do not hesitate to ask if unsure.
  Application.EnableEvents = False
  
  For n = 1 To UBound(arrNames)
    
    If FSO.FileExists(ThisWorkbook.Path & FOLDER_NAME & Left$(arrNames(n), Len(arrNames(n)) - 4) & "#01.xls") Then
      
      Set wbSource = Workbooks.Open(ThisWorkbook.Path & FOLDER_NAME & Left$(arrNames(n), Len(arrNames(n)) - 4) & "#01.xls", , True)
      Set wbDestination = Workbooks.Open(ThisWorkbook.Path & FOLDER_NAME & arrNames(n))
      
      'Tack in a sheet so we can move all pre-existing sheets
      wbSource.Worksheets.Add wbSource.Worksheets(1)
      
      Do While wbSource.Worksheets.Count >= 2
        wbSource.Worksheets(2).Move After:=wbDestination.Worksheets(wbDestination.Worksheets.Count)
      Loop
      
      wbSource.Close False
      Kill ThisWorkbook.Path & FOLDER_NAME & Left$(arrNames(n), Len(arrNames(n)) - 4) & "#01.xls"
      DoEvents
      wbDestination.Close True
      
    End If
  Next
  
  Application.EnableEvents = True
  
End Sub