ExcelBanter - Help required for macro

shrini wrote:

I want a little help 1 I want a macro for following

I have year wise folder ( e g 2015,2016) in this folder there is
monthwise folder (jan,feb....)
In month wise folder there are five workbook(AAA,BBB,CCC,DDD,EEE)
In each workbook there will be many sheet(a,b,c,d,....)
I want to particular sheet(suppose sheet c) to be copy from each work
book and paste in one new workbbk

This wasn't tested very thoroughly, but it seems to work.

Sub startup()
'This is the sub you run. It calls the worker sub and passes the top
'level of your directory tree (the directory that has the "year"
'subdirs). It must be a full path or expect some serious failure.
grabEverything "D:\1"
End Sub

Sub grabEverything(where As String)
'This sub does all the work.
Dim working As String, L0, L1
Dim src As Workbook, tgt As Workbook
ReDim dirlist1(0) As String, dirlist2(0) As String

Set tgt = ActiveWorkbook
ChDrive where
ChDir where
'build top-level dir list
working = Dir$("*", vbDirectory)
While Len(working)
If (GetAttr(working) And vbDirectory) And _
(Left$(working, 1) < ".") Then
ReDim Preserve dirlist1(UBound(dirlist1) + 1)
dirlist1(UBound(dirlist1)) = working
End If
working = Dir$
Wend
If UBound(dirlist1) = 0 Then Exit Sub 'no dirs found
For L0 = 1 To UBound(dirlist1)
'clear any previous use of dirlist2
ReDim dirlist2(0)
ChDir dirlist1(L0)
working = Dir$("*", vbDirectory)
'build subdir list
While Len(working)
If (GetAttr(working) And vbDirectory) And _
(Left$(working, 1) < ".") Then
ReDim Preserve dirlist2(UBound(dirlist2) + 1)
dirlist2(UBound(dirlist2)) = working
End If
working = Dir$
Wend
If UBound(dirlist2) 1 Then 'subdirs found
For L1 = 1 To UBound(dirlist2)
ChDir dirlist2(L1)
working = Dir$("*.xls*")
While Len(working)
Set src = Workbooks.Open(Filename:=working, _
UpdateLinks:=False, ReadOnly:=True)
'This avoids the need to worry about checking if the named sheet
'exists -- if it doesn't, Excel will ignore the error and march
'on. This also means that if a rename fails, further attempts to
'copy will also fail.
On Error Resume Next
src.Sheets("C").Copy Befo=tgt.Sheets(1)
'Have to rename the sheet to avoid name collision.
'We'll use the original file's path.
'Should end up as yyyy-mmm-???, e.g. "2018-jun-aaa".
tgt.Sheets("C").Name = dirlist1(L0) & "-" & dirlist2(L1) & "-" _
& Left$(working, InStrRev(working, ".") - 1)
'back to normal error handling
On Error GoTo 0
src.Close SaveChanges:=False
working = Dir$
Wend
ChDir ".."
Next L1
End If
ChDir ".."
Next L0
End Sub

--
If my heart was still alive, I know it would surely break.