VBA code to copy worksheet from a file (from one folder) to another file (from another folder)

[amaresh achar]

Hi,

I have about 3000 files in Folder-A and 6000 files in Folder-B

Folder-A has files with file names like:
PARTNO1.xlsm
PARTNO2.xlsm
PARTNO3.xlsm
PARTNO4.xlsm
PARTNO5.xlsm
PARTNO6.xlsm
.
.
.
PARTNO3000.xlsm

Folder-B has files with file names like:
PARTNO1_SCODE_PROD.xlsm
PARTNO1_SCODE_SAMP.xlsm
PARTNO2_SCODE_PROD.xlsm
PARTNO2_SCODE_SAMP.xlsm
PARTNO3_SCODE_PROD.xlsm
PARTNO3_SCODE_SAMP.xlsm
PARTNO4_SCODE_PROD.xlsm
PARTNO4_SCODE_SAMP.xlsm
PARTNO5_SCODE_PROD.xlsm
PARTNO5_SCODE_SAMP.xlsm
PARTNO6_SCODE_PROD.xlsm
PARTNO6_SCODE_SAMP.xlsm
.
.
.
PARTNO3000_SCODE_PROD.xlsm
PARTNO3000_SCODE_SAMP.xlsm

Each file from Folder-B has a part of its name exactly same as file name in Folder-B.... With that as reference,

In every file of Folder-A, there is a worksheet named "Balloon Drawing"

From Folder-A, From each files, I want to copy that "Balloon Drawing" sheet to the files in Folder-B which contains shares similar file name.

Eg: Folder-A --> PARTNO13.xlsm ("Balloon Drawing" sheet from this file)
Folder-B --> PARTNO13_SCODE_PROD.xlsm (to be copied to this file) and PARTNO13_SCODE_SAMP.xlsm (and this file)

Thanks in Advance....

 

[amaresh achar]

Hi,

I have about 3000 files in Folder-A and 6000 files in Folder-B

Folder-A has files with file names like:
PARTNO1.xlsm
PARTNO2.xlsm
PARTNO3.xlsm
PARTNO4.xlsm
PARTNO5.xlsm
PARTNO6.xlsm
.
.
.
PARTNO3000.xlsm

Folder-B has files with file names like:
PARTNO1_SCODE_PROD.xlsm
PARTNO1_SCODE_SAMP.xlsm
PARTNO2_SCODE_PROD.xlsm
PARTNO2_SCODE_SAMP.xlsm
PARTNO3_SCODE_PROD.xlsm
PARTNO3_SCODE_SAMP.xlsm
PARTNO4_SCODE_PROD.xlsm
PARTNO4_SCODE_SAMP.xlsm
PARTNO5_SCODE_PROD.xlsm
PARTNO5_SCODE_SAMP.xlsm
PARTNO6_SCODE_PROD.xlsm
PARTNO6_SCODE_SAMP.xlsm
.
.
.
PARTNO3000_SCODE_PROD.xlsm
PARTNO3000_SCODE_SAMP.xlsm

Each file from Folder-B has a part of its name exactly same as file name in Folder-B.... With that as reference,

In every file of Folder-A, there is a worksheet named "Balloon Drawing"

From Folder-A, From each files, I want to copy that "Balloon Drawing" sheet to the files in Folder-B which contains shares similar file name.

Eg: Folder-A --> PARTNO13.xlsm ("Balloon Drawing" sheet from this file)
Folder-B --> PARTNO13_SCODE_PROD.xlsm (to be copied to this file) and PARTNO13_SCODE_SAMP.xlsm (and this file)

Thanks in Advance....

*Correction: "Each file from Folder-B has a part of its name exactly same as file name in Folder-A.... With that as reference,"

 

[I_know_nuffin]

Hi

try the below code

you will need to update the folder paths and file extensions to suite your situation

I must warn you its not fast and I would recommend you run it on test copies to verify it works for you

and 3000 files will take ages I would copy the the A files to a separate folder and run 100 or so at a time

Function FindSimilarFiles(filepathcopy As String, Fname As String, filearray() As String) As Integer
'find similar files in other folder
Dim x As Integer
    newname = Dir(filepathcopy & Fname & "*.xls") 'Note change the extension to suit your file extension e.g xlsx, xlsm
    Do While newname <> ""
        Debug.Print newname
        filearray(x) = filepathcopy & newname
        x = x + 1
        newname = Dir
    Loop
    FindSimilarFiles = x
End Function



Sub LoopAllFilesInFolder()

Dim StartTime As Double
Dim StartTime1 As Double
Dim SecondsElapsed As Double

Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim FSOFile As Object

Dim filename As String, filepath As String, filepathcopy As String
Dim Fname As String, fromname As String, toname As String, Tabname As String
Dim frombook As Workbook, tobook As Workbook
Dim filearray(10) As String, x As Integer, y As Integer, lastsheet As Integer

Dim sht As Worksheet

Dim xlApp As Object

On Error GoTo Errortrap

 StartTime = Timer
 StartTime1 = StartTime

Set xlApp = CreateObject("Excel.Application")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

xlApp.Visible = False

'This code ran successfully in 244.02 seconds for 11 files using network
'This code ran successfully in 46.17 seconds for 11 files using c drive


xlApp.ScreenUpdating = False
xlApp.DisplayAlerts = False

'Set the foldernames to the variables
'your example Folder A
  filepath = "your folder path" ' note add the end "\" to the path string
'your example Folder B
  filepathcopy = "your other folder path" ' note add the end "\" to the path string
  
 'set the Tab name to copy from
 Tabname = "Balloon Drawing"

'Set all the references to the FSO Library
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.GetFolder(filepath)

'Use For Each loop to loop through each file in the folder
For Each FSOFile In FSOFolder.Files
DoEvents
       
    filename = FSOFile.Name
    
    Fname = Replace(filename, ".xls", "") 'change the extension to suit your file extension e.g xlsx, xlsm
    'Debug.Print Fname
    
    fromname = filepath & filename
    'Debug.Print fromname
    
    Fname = Replace(filename, ".xls", "") 'change the extension to suit your file extension e.g xlsx, xlsm
    'Debug.Print Fname
    
    fromname = filepath & filename
    'Debug.Print fromname
    
    ' use Fname to find similar files in the other folder and populate the Array
    x = FindSimilarFiles(filepathcopy, Fname, filearray())
    
    
    Set frombook = xlApp.Workbooks.Open(fromname) 'changed from add to open

    For y = 0 To x - 1

    Set tobook = xlApp.Workbooks.Open(filearray(y))
    
    frombook.Worksheets(Tabname).Activate
    
    lastsheet = tobook.Sheets.Count

    frombook.Worksheets(Tabname).Copy after:=tobook.Worksheets(lastsheet)
    
    tobook.Close SaveChanges:=True
    
    Next y
   
    frombook.Close SaveChanges:=False
    
  'SecondsElapsed = Round(Timer - StartTime, 2)
  'StartTime = Timer

'Notify user in seconds
  'Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"
  
  Stop ' this can be commented out once your happy it works
       ' press F5 to run for next file
  
Next

xlApp.ScreenUpdating = True
xlApp.DisplayAlerts = True

xlApp.Quit

Set xlApp = Nothing

'Release the memory
Set FSOLibrary = Nothing
Set FSOFolder = Nothing

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True


  SecondsElapsed = Round(Timer - StartTime1, 2)

'Notify user in seconds
  Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"



Exit Sub


Errortrap:

'close hidden workbooks
Stop

frombook.Close SaveChanges:=False
tobook.Close SaveChanges:=False


xlApp.ScreenUpdating = True
xlApp.DisplayAlerts = True


xlApp.Quit

Set xlApp = Nothing

'Release the memory
Set FSOLibrary = Nothing
Set FSOFolder = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

 

[amaresh achar]

Thank you so much I_know_nuffin, Its working exactly as per my requirements.... I just test ran it on 54 files in Folder-A, and 108 files in Folder-B, and the entire task has been completed within 2 minutes...!!! You are just AWESOME....!!! thank you so much...!!! Loved your work...!!! With this, I completed software portion of my project...!!!

 

[I_know_nuffin]

Glad to help and happy it worked for you