Copying from Multiple Wb in 1 folder to 1 Wb

[Solved/Closed]
Report
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Hello,

You guys have been a great help for all my naive questions, so I have another for you. When it comes to architecting the layout of the code I think I've got it figured out, but when it comes to the actual syntax, I get so lost.

Here is what I would like to do.

I want to copy Sheet(ddmmmyyyy) from all the workbooks in one folder to Sheet(ddmmmyyyy) in workbook("Master.xlsm"). I want to do this upon opening Master.xlsm. This part I can do. I have set up a scheduled task to open Master.xlsm, and then found a macro that will run the macro and then save and close the file.
The next part is I created a macro to create worksheet(ddmmmyyyy) in Master.xlsm. Now I get lost. I think I know the steps, but don't know the code from here. I need to make a loop that will:
1 - Open all the files in the folder (except "Master.xlsm")
2 - Create a loop that will find the last row of data (except row 1) and copy that range, and paste it to workbooks("Master.xlsm").worksheets(ddmmmyyyy) starting at the next blank row.
3 - Close the files after they are copied
Here is my interpretation of it:
-------------------------------------------------------
For Each file in folder
If file <> workbooks("Master.xlsm") Then
Open.file
find last row in workbook(file).worksheets(ddmmmyyyy)
range(A2:I"lastrow").copy
paste into first emtpy row of workbook("Master.xlsm").worksheets(ddmmmyyyy)
Close.file
End If
Next file
----------------------------------------------------------
I am just not familiar enough with the coding to be able to organize it properly. Any help would be greatly appreciated.

Thank you,
Josh

11 replies

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
rizvisa1:

Thank you for pointing me to that topic. Here is what I've tried, but I have the error coming up as the previous person had as well. I get the error 1004. It shows me the right file, but doesn't want to open it. It says it can't be found?

-------------------------------------------------------------
Private Sub CommandButton1_Click()

Dim sThisFilePath As String
Dim sFile As String
Dim wbBook As Workbook

sThisFilePath = ActiveWorkbook.Path
If (Right(sThisFilePath, 1) <> "\") Then sThisFilePath = sThisFilePath & "\"

sFile = Dir(sThisFilePath & "*.xls*")
MsgBox "The path is " & sThisFilePath
ChDir (sThisFilePath)

Do While sFile <> vbNullString
MsgBox "The next file is " & sFile
'if the next file is same as "active file" then skip the file
If (sFile = ActiveWorkbook.Name) Then GoTo Next_File

Set wbBook = Workbooks.Open(sFile) <<<<<<error 1004
'My code placed here

' wbBook.Close SaveChanges:=True

Next_File:
sFile = Dir
Loop
Set wbBook = Nothing


Application.ScreenUpdating = True

End Sub
-----------------------------------------------------------
Scratch that. If I just learn to read further. Changing Set wbBook = Workbooks.Open(sFile) to Set wbBook = Workbooks.Open(sThisFilePath & sFile) and I'm set. I even changed If (sFile = ActiveWorkbook.Name) Then GoTo Next_File to If (sFile = "Master.xlsm") Then GoTo Next_File and it doesn't worry about that that file being open. Now, my next step is to copy the information from those files in worksheets(ddmmmyyyy) to workbooks("Master.xlsm").worksheets(ddmmmyyyy). Help with this would be greaty appreciated.
Thank you,
Josh
Here is my feeble attempt at the rest of my project. I am sure I mangled the copy/paste code something fierce. Assistance is greatly appreciated and all the help to this point has been spectacular.

Thank you,
Josh

---------------------------------------------------------------------------
Private Sub CommandButton1_Click()

Dim sThisFilePath As String
Dim sFile As String
Dim wbBook As Workbook
Dim mFinalRow, sFinalRow As Long

mFinalRow = Cells(Rows.Count, 1).End(xlUp).Row


sThisFilePath = ActiveWorkbook.Path
If (Right(sThisFilePath, 1) <> "\") Then sThisFilePath = sThisFilePath & "\"

sFile = Dir(sThisFilePath & "*.xls*")
MsgBox "The path is " & sThisFilePath
ChDir (sThisFilePath)

Do While sFile <> vbNullString
MsgBox "The next file is " & sFile
'if the next file is same as "active file" then skip the file
If (sFile = "Master.xlsm") Then GoTo Next_File

Set wbBook = Workbooks.Open(sThisFilePath & sFile)
'My code placed here
sFinalRow = Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(sFile).Worksheets("24Apr2012").Range(Cells(2, 1), Cells(sFinalRow, "I")).Copy Destination:=Workbooks("Master.xlsm").Worksheets("24Apr2012").Cells(mFinalRow, 1) '<<<<<<<<this is where I get the error right now. The idea was to find the bottom row of the opened workbook, and copy the range from A2:I"sFinalRow" and paste it to Master.xlsm at A"mFinalRow">>>>>>>>>>>>

mFinalRow = mFinalRow + sFinalRow


' wbBook.Close SaveChanges:=True

Next_File:
sFile = Dir
Loop
Set wbBook = Nothing


Application.ScreenUpdating = True

End Sub
-------------------------------------------------------------------------------
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
You can try this

1 you open the master book,
2 read the last row (as you are doing in other). store in variable
3 open the other book
4 copy the range
5 paste the cells
6 close the other book
repeat step 2-6
rizvisa1:

I appreciate the advise. It helped me simplify my thinking and get me through my process. However, I think there is a more efficient manner to handle my code, and I would like to see any suggestions to this. Also, one thing I haven't been able to figure out, unless I create its own loop, is to copy the name of the workbook I am copying from into column J. Could I just add a line that is

Range("J" & mFinalRow":J" & mFinalRow+sFinalRow - 2).Value = sFile

or would I have to add another variable to do this?

-----------------------------------------------------------------
Private Sub CommandButton1_Click()

Dim sThisFilePath As String
Dim sFile As String
Dim wbBook As Workbook
Dim mFinalRow, sFinalRow, newFinalRow As Long

sThisFilePath = ActiveWorkbook.Path
If (Right(sThisFilePath, 1) <> "\") Then sThisFilePath = sThisFilePath & "\"
sFile = Dir(sThisFilePath & "*.xls*")
MsgBox "The path is " & sThisFilePath
ChDir (sThisFilePath)

Do While sFile <> vbNullString
MsgBox "The next file is " & sFile

'if the next file is same as "active file" then skip the file
If (sFile = "Master.xlsm") Then GoTo Next_File

'Opens the next workbook in that folder
Set wbBook = Workbooks.Open(sThisFilePath & sFile)

'Find the final row of the newly opened workbook
sFinalRow = Workbooks(sFile).Worksheets("24Apr2012").Cells(Rows.Count, 1).End(xlUp).Row

'Copy from A2:I(sFinalRow) from current workbook
Workbooks(sFile).Worksheets("24Apr2012").Range("A2:I" & sFinalRow).Copy

'Find the last row in the main workbook then adds 1
mFinalRow = Workbooks("Master.xlsm").Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
mFinalRow = mFinalRow + 1

'Paste those copied cells in the first available open row
Workbooks("Master.xlsm").Worksheets("Sheet1").Cells(mFinalRow, 1).PasteSpecial

' wbBook.Close SaveChanges:=True

Next_File:
sFile = Dir
Loop
Set wbBook = Nothing

Application.ScreenUpdating = True

End Sub
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
One thing that I am trying to "unlearn" is thinking about efficiency ahead before it is proven to be a concern. Idea is that once you know that you have some efficiency issue, you tackle it. Saving a minute is not worth the effort. As I said, I am still trying "unlearn", need for always efficient code.

Looking at your code, there is not much of a chance for making it more efficient. Only part where there might be room is copy and paste can be accomplish in one step. But this on times cause issues. So I guess question is saving quarter of a minute worth the pain

Here is an updated code. Base code is your. Just a minor tweak along with your second point about file name
Option Explicit

Private Sub CommandButton1_Click()

Dim wbSource            As Workbook
Dim wbMasterSheet       As Worksheets
Dim sTargetSheet        As String
Dim sThisFilePath       As String
Dim sFile               As String
Dim lMaxSourceRow       As Long
Dim lMasterLastRow      As Long

   sThisFilePath = ActiveWorkbook.Path
   If (Right(sThisFilePath, 1) <> "\") Then sThisFilePath = sThisFilePath & "\"
   sFile = Dir(sThisFilePath & "*.xls*")

   sTargetSheet = "24Apr2012"
   
   Set wbMasterSheet = Workbooks("Master.xlsm").Sheets("Sheet1")
   lMasterLastRow = getItemLocation("*", wbMasterSheet.Cells)
   lMasterLastRow = lMasterLastRow + 1
   
   Do While sFile <> vbNullString
      MsgBox "The next file is " & sFile
      
      'if the next file is same as "active file" then skip the file
      If (sFile = wbMasterSheet.Parent.Name) Then GoTo Next_File
      
      'Opens the next workbook in that folder
      Set wbSource = Workbooks.Open(sThisFilePath & sFile)
      
      'Find the final row of the newly opened workbook
      lMaxSourceRow = getItemLocation("*", wbSource.Sheets(sTargetSheet).Cells)
      
      If lMaxSourceRow = 0 Then GoTo Next_File
      
      Application.CutCopyMode = False
      'Copy from A2:I(sFinalRow) from current workbook
      wbSource.Worksheets(sTargetSheet).Range("A2:I" & lMaxSourceRow).Copy
            
      With wbMasterSheet
         
         'Paste those copied cells in the first available open row
         .Cells(lMasterLastRow, 1).PasteSpecial
         Application.CutCopyMode = False
         
         'put the file name
         .Range(.Cells(lMasterLastRow, "J"), .Cells(lMasterLastRow + lMaxSourceRow - 1, "J")).Value = sFile
      End With
      
      ' increment the position market of master
      lMasterLastRow = lMasterLastRow + lMaxSourceRow
   
Next_File:
      If (sFile = wbMasterSheet.Parent.Name) Then wbSource.Close SaveChanges:=False
   
      sFile = Dir
   Loop
   Set wbSource = Nothing
   Set wbMasterSheet = Nothing
   
   MsgBox "Process Completed"
   
   Application.ScreenUpdating = True

End Sub

Public Function getItemLocation(sLookFor As String, _
                                rngSearch As Range, _
                                Optional bFullString As Boolean = True, _
                                Optional bLastOccurance As Boolean = True, _
                                Optional bFindRow As Boolean = True) As Long
                                   
   'find the first/last row/column  within a range for a specific string
      
   Dim Cell             As Range
   Dim iLookAt          As Integer
   Dim iSearchDir       As Integer
   Dim iSearchOdr       As Integer
         
   If (bFullString) _
   Then
      iLookAt = xlWhole
   Else
      iLookAt = xlPart
   End If
   If (bLastOccurance) _
   Then
      iSearchDir = xlPrevious
   Else
      iSearchDir = xlNext
   End If
   If Not (bFindRow) _
   Then
      iSearchOdr = xlByColumns
   Else
      iSearchOdr = xlByRows
   End If
         
   With rngSearch
      If (bLastOccurance) _
      Then
         Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
      Else
         Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
      End If
   End With
         
   If Cell Is Nothing Then
      getItemLocation = 0
   ElseIf Not (bFindRow) _
   Then
      getItemLocation = Cell.Column
   Else
      getItemLocation = Cell.Row
   End If
   Set Cell = Nothing

End Function

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
ofcourse the code is untested. So you may find issues
Hello again:
I have run into an error that I just can't seem to wrap my head around. It works just fine when I have it set as a Button Click from the worksheet, but it won't run correctly when I try putting it in the Workbook to run when it's opened. Any and all assistance would be appreciated.
I have tried to mark where I am getting the "Subscript out of range" error in the code below.
Thank you,
---------------------------------------------------------------------------
Private Sub Workbook_Open()
Dim sThisFilePath As String
Dim sFile, sFileName, shToday, shTomorrow As String
Dim wbBook As Workbook
Dim wkSheet, FirstSht, SecondSht As Worksheet
Dim mFinalRow, sFinalRow, newFinalRow As Long
Dim Today, Tomorrow As Date
Dim d, j

Application.ScreenUpdating = False

Today = Date
If Weekday(Today) = 6 Then
Tomorrow = Date + 3
Else
Tomorrow = Date + 1
End If
shToday = Format(Today, "ddmmmyyyy")
shTomorrow = Format(Tomorrow, "ddmmmyyyy")

For Each wkSheet In ThisWorkbook.Worksheets
If wkSheet.Name = shToday Then GoTo EndOfCode
Next wkSheet
Sheets("Sheet1").Select

Sheets("Sheet1").Copy After:=Sheets(1)
ActiveSheet.Select
'Sheets("Sheet1").Visible = False


ActiveSheet.Name = shToday
Set nSheet = ActiveSheet

sThisFilePath = ActiveWorkbook.Path
If (Right(sThisFilePath, 1) <> "\") Then sThisFilePath = sThisFilePath & "\"
sFile = Dir(sThisFilePath & "*.xls*")
'MsgBox "The path is " & sThisFilePath
ChDir (sThisFilePath)

Do While sFile <> vbNullString
'MsgBox "The next file is " & sFile
'if the next file is same as "active file" then skip the file
If (sFile = "Test.xlsm") Then GoTo Next_File
'Opens the next workbook in that folder
Set wbBook = Workbooks.Open(sThisFilePath & sFile)
'Creates a copy of the Resource update sheet in the resource file
Sheets("Sheet2").Visible = True <<<<<<<<<<<<<<<<<<<<<<<ERROR
Set OldSheet = Workbooks(sFile).Worksheets(shToday)
Sheets("Sheet2").Copy After:=Sheets(2)
'Names the new sheet with the date
ActiveSheet.Name = shTomorrow
Set NwSheet = ActiveSheet
Sheets("Sheet2").Visible = False
'Updates the resource workbook for the next day
d = 1
j = 2
Do Until IsEmpty(OldSheet.Range("A" & j))

If (OldSheet.Range("I" & j) = "No") Or (OldSheet.Range("I" & j) = "") Then
d = d + 1
NwSheet.Rows(d).Value = OldSheet.Rows(j).Value
End If

j = j + 1
Loop
'Find the final row of the newly opened workbook
sFinalRow = Workbooks(sFile).Worksheets(shToday).Cells(Rows.Count, 1).End(xlUp).Row
If sFinalRow = 1 Then GoTo Next_File:
'Copy from A2:I(sFinalRow) from current workbook
Workbooks(sFile).Worksheets(shToday).Range("A2:I" & sFinalRow).Copy
'Find the last row in the main workbook then adds 1
mFinalRow = nSheet.Cells(Rows.Count, 1).End(xlUp).Row
mFinalRow = mFinalRow + 1
'Paste those copied cells in the first available open row
nSheet.Cells(mFinalRow, 1).PasteSpecial xlValues

sFileName = Left(sFile, (InStrRev(sFile, ".", -1, vbTextCompare) - 1))
nSheet.Range("J" & mFinalRow, "J" & mFinalRow + sFinalRow - 2).Value = sFileName
Application.CutCopyMode = False

wbBook.Close SaveChanges:=True

Next_File:
sFile = Dir
Loop
Set wbBook = Nothing

EndOfCode:
Application.ScreenUpdating = True

End Sub
--------------------------------------------------------------------
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Do you have this sheet ?
Sheets("Sheet2").Visible = True <<<<<<<<<<<<<<<<<<<<<<<ERROR
yes, I do have that sheet. I had even thought about that this weekend. I should have anticipated that question. However, I might be confused as to which workbook it is asking about that sheet? But, every time I look at the code, it appears that it is pointing a workbook that I open, not "Test.xlsm". I don't have "Sheet2" in "Test.xlsm". My guess, and this is just a guess and I have no clue, is that it might be the way I'm trying to call the Sheets function within "Thisworkbook" component in the macro environment? I've tried playing around with it to try and make it work with Workbook.Worksheets functions and those didn't work either. But, then again, I could have been using those incorrectly too. I appreciate your assistance with trying to resolve this issue.
Thank you,
Josh
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
from code
Set wbBook = Workbooks.Open(sThisFilePath & sFile)
'Creates a copy of the Resource update sheet in the resource file
Sheets("Sheet2").Visible = True

It should be looking for sheet2 in the file that you just opened in the line above

i
Exactly. Which is what it does when I use the Click event (within the individual worksheets), but that's where it as the error when I try to do the Open event (in Thisworkbook). If it doesn't make sense, I will take a screen shot when I get the opportunity to try and illustrate what I am referring to. I do appreciate the assistance in understanding this issue.
Thank you,
Josh
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
I think the issue it that your other file is still executing the code.
I think if you refer the sheet with workbook that would work
Set wbBook = Workbooks.Open(sThisFilePath & sFile)
'Creates a copy of the Resource update sheet in the resource file
wbBook.Sheets("Sheet2").Visible = True
rizvisa1:

You're awesome! In my initial tests, it seems to be working. I had to make a few more changes, other than just "wbBook.Sheets("Sheet2").Visible=True, but they were relatively easy to figure out as the errors came up. Just had to add "wbBook" to a few other lines. I will let you know tomorrow for sure as I have set up a scheduled task to run on the full thing.
Thank you,
Josh
I have run into a few issues with this process. 1 - Users left the workbook open, so when I tried to access them through my "Test" workbook, it would error out. 2 - When I tried to implement an "idle" closesout, they didn't have macros enabled. I now have the users with macros enabled and will have a clear understanding tomorrow after my task runs again.

At this point, this thread can be marked Solved!!!!!

Thank you very much with all your help. If you are interested in the final code, please let me know and I will be more than happy to share. I have tied in multiple things that I have learned from the assistants on this site. I am sure as my project evolves, I will have more questions, but you all have been very helpful in getting a working/functioning version to use for us.

Thank you,
Josh
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
If you post your final version, it just may help some one else.
Here is the final code I put in ThisWorkbook of "Test.xlsm"
If it wasn't for the help of everyone here, I would not have gotten this far with it. Thank you.
------------------------------------------------------------------------------------
Private Sub Workbook_Open()
Dim sThisFilePath As String
Dim sFile, sFileName, shToday, shTomorrow As String
Dim wbBook As Workbook
Dim wkSheet, FirstSht, SecondSht As Worksheet
Dim mFinalRow, sFinalRow, newFinalRow As Long
Dim Today, Tomorrow As Date
Dim d, j

Application.ScreenUpdating = False

Today = Date
If Weekday(Today) = 6 Then
Tomorrow = Date + 3
Else
Tomorrow = Date + 1
End If
shToday = Format(Today, "ddmmmyyyy")
shTomorrow = Format(Tomorrow, "ddmmmyyyy")

For Each wkSheet In ThisWorkbook.Worksheets
If wkSheet.Name = shToday Then GoTo EndOfCode
Next wkSheet
Sheets("Sheet1").Select

Sheets("Sheet1").Copy After:=Sheets(1)
ActiveSheet.Select
'Sheets("Sheet1").Visible = False


ActiveSheet.Name = shToday
Set nSheet = ActiveSheet

sThisFilePath = ActiveWorkbook.Path
If (Right(sThisFilePath, 1) <> "\") Then sThisFilePath = sThisFilePath & "\"
sFile = Dir(sThisFilePath & "*.xls*")
'MsgBox "The path is " & sThisFilePath
ChDir (sThisFilePath)

Do While sFile <> vbNullString
'MsgBox "The next file is " & sFile
'if the next file is same as "active file" then skip the file
If (sFile = "Test.xlsm") Then GoTo Next_File
'Opens the next workbook in that folder
Set wbBook = Workbooks.Open(sThisFilePath & sFile)
'Creates a copy of the Resource update sheet in the resource file
wbBook.Sheets("Sheet2").Visible = True
Set OldSheet = Workbooks(sFile).Worksheets(shToday)
wbBook.Sheets("Sheet2").Copy After:=wbBook.Sheets(2)
'Names the new sheet with the date
wbBook.ActiveSheet.Name = shTomorrow
Set NwSheet = wbBook.ActiveSheet
wbBook.Sheets("Sheet2").Visible = False
'Updates the resource workbook for the next day
d = 1
j = 2
Do Until IsEmpty(OldSheet.Range("A" & j))

If (OldSheet.Range("K" & j) = "No") Then
d = d + 1
NwSheet.Rows(d).Value = OldSheet.Rows(j).Value
ElseIf (OldSheet.Range("K" & j) = "no") Then
d = d + 1
NwSheet.Rows(d).Value = OldSheet.Rows(j).Value
ElseIf OldSheet.Range("K" & j) = "" Then
d = d + 1
NwSheet.Rows(d).Value = OldSheet.Rows(j).Value
End If

j = j + 1
Loop
'Find the final row of the newly opened workbook
sFinalRow = Workbooks(sFile).Worksheets(shToday).Cells(Rows.Count, 1).End(xlUp).Row
'MsgBox "The final row is " & sFinalRow
If sFinalRow = 1 Then GoTo Close_File:
'Copy from A2:I(sFinalRow) from current workbook
Workbooks(sFile).Worksheets(shToday).Range("A2:K" & sFinalRow).Copy
'Find the last row in the main workbook then adds 1
mFinalRow = nSheet.Cells(Rows.Count, 1).End(xlUp).Row
mFinalRow = mFinalRow + 1
'Paste those copied cells in the first available open row
nSheet.Cells(mFinalRow, 1).PasteSpecial xlValues

sFileName = Left(sFile, (InStrRev(sFile, ".", -1, vbTextCompare) - 1))
nSheet.Range("L" & mFinalRow, "L" & mFinalRow + sFinalRow - 2).Value = sFileName
Application.CutCopyMode = False
Close_File:
wbBook.Close SaveChanges:=True

Next_File:
sFile = Dir
Loop
Set wbBook = Nothing

EndOfCode:
Application.ScreenUpdating = True

End Sub
-----------------------------------------------------------------------------------------------

Here is what I put in the user workbooks to prevent an Open workbook causing my main workbook to fail. I pulled this code from another site.

In ThisWorkbook
-----------------------------------------------------------------------------------------------
Option Explicit

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
ResetTimer
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
ResetTimer
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ResetTimer
End Sub
----------------------------------------------------------------------------------------------
In a module
----------------------------------------------------------------------------------------------

Public CloseDownTime As Variant

Public Sub ResetTimer()
On Error Resume Next
If Not IsEmpty(CloseDownTime) Then Application.OnTime EarliestTime:=CloseDownTime, Procedure:="CloseDownFile", Schedule:=False
CloseDownTime = Now + TimeValue("00:30:00") ' hh:mm:ss
Application.OnTime CloseDownTime, "CloseDownFile"
End Sub

Public Sub CloseDownFile()
On Error Resume Next
Application.StatusBar = "Inactive File Closed: " & ThisWorkbook.Name
ThisWorkbook.Close SaveChanges:=True
End Sub
----------------------------------------------------------------------------------------------
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
thanks and congrats!!