Merge mulitiple workbooks into sheet with code in it. Protected books. Urgent

Hi all.

Ok i'm pretty new to Macros so i'm pretty newbish so don't even know where to start.

I'm working in a company and we are doing call trackers where people fill in data into a couple of columns in rows downwards.

Starts at Row 3 and all data between column B to H.

What i have now is a master workbook which has multiple sheets for management.
Each analyst has a workbook with just one sheet.

I want sheet1 of all analysts to be copied to sheet1 in my master workbook.

All workbooks are protected so need to add code for that.

All workbooks are in seperate folders but they are all subfolders to one parent folder..
which is \\ph-fs002\project\jes\

Thing is that there are multiple workbooks in each folder but i just want it to use one of them. possibly can i have a box above where i write the name it will look for(they will all be called the same)

So basicly it needs to go into each, unprotect it, copy all data between B3:H500, send into next blank field of my workbook and loop this untill it's done with all and also want it to show in the end a message saying # logsheets merged successfully if it didnt work then just failed or something and if possible showing why it failed.

know if you do this it will prompt to save each one because each is opened.. some way to go around this? each will not need to be saved as then they wont be protected anymore.. can press cancel over and over again but would be easier if there was a way around it.

I want this activated by a button btw if that matters..

If needed my workbook can be in one of the subfolders as well..

Anymore information needed?

Hopefully someone can help, been working on this for days now without getting anywhere and the dead line for completion of this i nearing

Best regards
Christian

Hey. thanks for the reply.

The code i'm playing around with is below.

Can't figure out where it fails. It does merge something but for some reason its some timestamps going into sheet 6.. Want everything from sheet 1.. to go into sheet 1 in my main to the next blank row. Any idea whats wrong?

Would also need to add a unprotect code as this is needed i would think or less it wont copy over or?

Hope someone can help with this.

It's going btw from B3 to G1000. Sheet1!B3:G1000 should be copied to the workbook(where the code is in) in sheet1 starting at first blank row pasting to B:G.. A should be left alone as thats just numbers and will be a total count in the end.

Option Explicit

Sub ImportSameFileNameDataAllSubFolders()


Dim fNAME As String: fNAME = "test.xlsm"
Dim fPATH As String: fPATH = "d:\logsheettesting\merge\"
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FLD As Object: Set FLD = FSO.GetFolder(fPATH)
Dim SubFLDRS As Object: Set SubFLDRS = FLD.Subfolders
Dim SubFLD As Object
Dim wbMain As Workbook: Set wbMain = ThisWorkbook
Dim wbData As Workbook
Dim ws As Worksheet
Dim LR As Long
Dim wsTest As String

Application.ScreenUpdating = False

For Each SubFLD In SubFLDRS
Set wbData = Workbooks.Open(fPATH & SubFLD.Name & "\" & fNAME)

On Error Resume Next

For Each ws In ActiveWorkbook.Worksheets
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("b3:F1000" & LR).EntireRow.Copy
With wbMain 'add sheet if needed
If Not Evaluate("ISREF('[" & wbMain.Name & "]" & ws.Name & "'!$A$1)") Then _
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = ws.Name
.Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
Next ws

Application.CutCopyMode = False
wbData.Close False
Next SubFLD

Set wbMain = Nothing
Application.ScreenUpdating = True
End Sub

This worked! however not 100%... I created 6 test folders with one file in each... same info in all.. jut file 1, 2 and 6 were merged.. deleted 6 to try and then it took 1, 2 and 5... any idea on why? also could someone help me add a message box in the end that lists how many files were merged?

Yea sadly it doesnt really show anything at all as it does show and wont give any error. It just doesnt take all folders for some reason. Also i will need to add a code to make it just check in each folder and see if it has the listed file i want it to copy, if not found then continue to next file. Now it shows a error if the file isnt in each folder.. The folder has **** loads of other folders which does not include the xlsm files at all so need to add this or it will be useless sadly.. any help?

Hey sorry for late response.

Yes it does work but the problem is that it gives a error for each folder the file is not in and for each one it does not find the expected file it actually copies the mainfile to itself actually...

thanks but adding that i get compile error: next without for.

The error i get when trying to merge before adding this when it does not find the file in a folder is "path\testing.xls" cannot be found. Check your spelling or try a different path.

So it shows that for each folder the file is not in. And for each folder the file is not in, the main file copies and pastes to self which is rather annoying as there are 6 folders and i then get 6*6 copies...

On error resume next is over for each subfld in subfldrs. Tried having it under there as well.. same stuff.

Any idea?

How can i change this code to just work for one sheet instead of the full workbook. I think that part might be causing some problems.
I've been trying to make some changes with no luck.

i'm using:
Option Explicit

Sub Em()


Dim fNAME As String: fNAME = ActiveWorkbook.Sheets("Sheet1").Cells(4, 10).Value
Dim fPATH As String: fPATH = "D:\Testing\Testing\"
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FLD As Object: Set FLD = FSO.GetFolder(fPATH)
Dim SubFLDRS As Object: Set SubFLDRS = FLD.Subfolders
Dim SubFLD As Object
Dim wbMain As Workbook: Set wbMain = ThisWorkbook
Dim wbData As Workbook
Dim ws As Worksheet
Dim LR As Long
Dim wsTest As String

Application.EnableEvents = False
Application.ScreenUpdating = False


On Error Resume Next
For Each SubFLD In SubFLDRS

Set wbData = Workbooks.Open(fPATH & SubFLD.Name & "\" & fNAME)

For Each ws In ActiveWorkbook.Worksheets
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws.Range("B3:H500" & LR).Copy
With wbMain
If Not Evaluate("ISREF('[" & wbMain.Name & "]" & ws.Name & "'!$A$1)") Then _
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = ws.Name
.Sheets(ws.Name).Range("E" & Rows.Count).End(xlUp).Offset(1).Offset(0, -3).PasteSpecial xlPasteValues
End With

Application.CutCopyMode = False
wbData.Close False

Next ws

Next SubFLD

Set wbMain = Nothing

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

how to split the data with multiple sheet to multiple workbook based on coloum




if sheet 1 has many data and also given the name chetan raj amit
and sheet 2 has given in pivot table who is linked in sheet1
and sheet 3 has given in chart who is linked in sheet1

then what should i do in this case
simple save as and delete the data

i need 3 workbook
1 chetan workbook with 3 sheets( 1 data, 2 pivot table, 3 chart)
2 raj workbook with 3 sheets ( 1 data, 2 pivot table, 3 chart)
3 amit workbook 3 sheets ( 1 data, 2 pivot table, 3 chart)


so can u help me
of this matter
any vb code