Copy from multiple files in a folder to multiple files in a different folder with corresponding name.

[phill63]

Hi there and thanks in advance for any help and tips.

So I am new to VBA and have just started playing around with it about two weeks ago.


I have been searching and haven't been able to find a solution for the problem I am hoping to solve.

I have two folders.

The name of the first folder is "Individual Trackers"

In the first folder are excel workbooks that are each titled "Person'sname_Tracker" so "John_Tracker" for example.

The workbooks contain one sheet with a header in row A and the number of rows with data varies from day to day.

The name of the second folder is "Individual Historic"

There are corresponding workbooks for each file in the "Individual Tracker" folder and are all titled as "Person'sname_Historic" so "John_Historic" for example.


What I am looking for is a macro that would open the first file in the tracker folder, copy all data from row B until the last row with data in it, paste it to the next available row in the corresponding file in the historic folder, then delete the data from the file in the first folder, and loop through until all files have been gone through.

If you have any ideas on how to make this work it would be greatly appreciated.

If need be the macro doesn't need to delete the data from the files in the first folder, as I already have a macro that is able to do just this part so i could just call it at the end of this one.

 

[John_w]

Welcome to MrExcel forum.

Use a Dir function loop to loop through each file in one of the folders (doesn't matter which). Open the file and corresponding other file (workbook) using Workbooks.Open - record a macro with you opening any workbook to get the basic syntax. Find the last populated row (in column A?) in destination workbook (search forum for this commonly required code) and Cut (1 line method of doing a Copy and Delete) UsedRange from source to destination. That's the basic method, and undoubtedly a few tweaks would be needed. Post back if you need help with this.

 

[phill63]

Thanks for the response John_w.

So I tried to piece together a few different things and this is the macro I have recorded so far. I am getting a Run-time error "424"
on the line shaded red. I think it has do do with my UnderScore_Delimit(1) not working properly.

Any idea how to fix this or a better way to do it?




Sub MoveIndividualHistory()
Dim FSO As New Scripting.FileSystemObject
Dim fld As Folder
Dim fls As File
Dim SPath As String
Dim SName As String
Dim HPath As String
Dim HName As String
Dim WBHis As Workbook
Dim WBCurrent As Workbook
Dim LastRowOpen As Long
Dim LastRowHis As Long
Dim UnderScore_Delimit As Variant


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False




SPath = "F:\Flows Folder\Individual Trackers"
HPath = "F:\Flows Folder\Individual History"
Set fld = FSO.GetFolder(SPath)


For Each fls In fld.Files
Set WBCurrent = Workbooks.Open(SPath & "\" & fls.Name)
UnderScore_Delimit = Split(WBCurrent.Name, "_")
Set WBHis = HPath & "\" & UnderScore_Delimit(1) & " History"
LastRowHis = WBHis.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
With ActiveSheet
LastRowOpen = .Cells(Rows.Count, "A").Edn(xlUp).Row
If LastRowOpen <> 1 Then
.Rows("2:" & LastRowOpen).Copy
WBHis.Sheets(1).Rows(LastRowHis + 1).PasteSpecial Paste:=xlPasteValues
End If
End With
WBHis.Close savechanges:=True
WBCurrent.Close savechanges:=False
Next

Application.ScreenUpdateing = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

 

[John_w]

        Set WBHis = HPath & "\" & UnderScore_Delimit(1) & " History"

Try something like (untested):

Set WBHis = Workbooks.Open(HPath & "\" & Replace(fls.Name,"_Tracker","_History"))

PS - please use CODE tags, like this:

[CODE]
VBA code here
[/CODE]

 

[phill63]

Sorry about not using the Code tags, I wasn't aware of them.

So with your suggestion I got the loop to correctly associate the correct history account with the tracker that is currently open.

However, even though the macro isn't saving anything to the history files. Any ideas on where I went wrong?

Sub MoveIndividualHistory()
    Dim FSO As New Scripting.FileSystemObject
    Dim fld As Folder
    Dim fls As File
    Dim SPath As String
    Dim SName As String
    Dim HPath As String
    Dim HName As String
    Dim WBHis As Workbook
    Dim WBCurrent As Workbook
    Dim LastRowOpen As Long
    Dim LastRowHis As Long
    Dim UnderScore_Delimit As Variant




    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False




    SPath = "F:\Flows Folder\Individual Trackers"
    HPath = "F:\Flows Folder\Individual History"
    Set fld = FSO.GetFolder(SPath)




    For Each fls In fld.Files
    Set WBCurrent = Workbooks.Open(SPath & "\" & fls.Name)
    Set WBHis = Workbooks.Open(HPath & "\" & Replace(fls.Name, "_Tracker", "_History"))
    LastRowHis = WBHis.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
        With ActiveSheet
        LastRowOpen = .Cells(Rows.Count, "A").End(xlUp).Row
            If LastRowOpen <> 1 Then
            .Rows("2:" & LastRowOpen).Copy
            WBHis.Sheets(1).Rows(LastRowHis + 1).PasteSpecial Paste:=xlPasteValues
            End If
        End With
    WBHis.Close savechanges:=True
    WBCurrent.Close savechanges:=False
    Next


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True


End Sub

 

[John_w]

Here's my take. Assumes .xls workbooks - if not, change this bit where commented in the code to .xlsx, or .xlsm, etc.

Public Sub Copy_from_Workbooks()

    Dim trackerFiles As String, trackerFolder As String, historicFolder As String
    Dim fileName As String
    Dim destinationCell As Range
    Dim historicWorkbook As Workbook
    
    'Folders and files to be copied from and to
    
    trackerFiles = "F:\Flows Folder\Individual Trackers\*.xls"      'CHANGE THE .xls IF NECESSARY
    historicFolder = "F:\Flows Folder\Individual Historic\"
    
    trackerFolder = Left(trackerFiles, InStrRev(trackerFiles, "\"))
    fileName = Dir(trackerFiles)
    
    While fileName <> ""
        Set historicWorkbook = Workbooks.Open(historicFolder & Replace(fileName, "Tracker", "Historic"))
        Set destinationCell = historicWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
        
        Workbooks.Open trackerFolder & fileName
        ActiveWorkbook.Sheets(1).UsedRange.Offset(1, 0).Cut destinationCell
        
        ActiveWorkbook.Close True
        historicWorkbook.Close True
        
        fileName = Dir()
    Wend

End Sub

 

[phill63]

Thanks for the code John,

I was playing around with mine and realized that my with ActiveSheet was messed up since the active sheet at that point in the code wasn't WBCurrent but was WBHis. I changed that line of coding and now my macro works.

I'm going to play around with the code you just sent me and whichever is faster is the one I will end up keeping. But once again thank you for the guidance.

Here's the code I ended up with in case you could use you for your own purposes.

Sub MoveIndividualHistory()


    Dim FSO As New Scripting.FileSystemObject
    Dim fld As Folder
    Dim fls As File
    Dim SPath As String
    Dim SName As String
    Dim HPath As String
    Dim HName As String
    Dim WBHis As Workbook
    Dim WBCurrent As Workbook
    Dim LastRowOpen As Long
    Dim LastRowHis As Long
    Dim UnderScore_Delimit As Variant


    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False


    SPath = "F:\Flows Folder\Individual Trackers"
    HPath = "F:\Flows Folder\Individual History"
    Set fld = FSO.GetFolder(SPath)


    For Each fls In fld.Files
        Set WBCurrent = Workbooks.Open(SPath & "\" & fls.Name)
        Set WBHis = Workbooks.Open(HPath & "\" & Replace(fls.Name, "_Tracker", "_History"))
        LastRowHis = WBHis.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
            With WBCurrent.Sheets(1)
                LastRowOpen = WBCurrent.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
                    If LastRowOpen <> 1 Then
                        .Rows("2:" & LastRowOpen).Copy
                        WBHis.Sheets(1).Rows(LastRowHis + 1).PasteSpecial Paste:=xlPasteValues
                    End If
            End With
        WBHis.Close savechanges:=True
        WBCurrent.Close savechanges:=False
    Next


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True


End Sub