Complicated (I think) Macro

[ExcelAmateur2014]

Hi

I have looked through your forums before joining in hope that the answer as there but haven' found it.

Basically I want to run a macro or something similar that will bring back the information from a set data range of all spreadsheets in that folder. Basically I am having a form that will be completed by other people which is in a set template format. I want to have a macro that will drag through the data range from each form within the folder automatically.

For example
There are 3 forms completed in the folder. I want my central data base to bring through the data on each form from cell B2. And relay it into the central spreadsheet eg.

Master spreads sheet will look like this after the Macro has run

A1 = 4
B1 = 2
C1 = 3

This basically has dragged through the data from cell B2 in each of the following spreadsheets which are all saved in a central folder.

Spreadsheet 1 – Cell B2 = 4
Spreadsheet 2 – Cell B2 = 2
Spreadsheet 3 – Cell B2 = 3

If I was then to add another spreadsheet into the folder “spreadsheet 4” which has the value of 7 in cell B2, then I run the Macro again then this data will then be added to cell D1 accordingly of the master sheet. Spreadsheet 5 will then feed into cell E1, spreadsheet 6 will feed data in to cell F1 of the mastersheet and so on.

Obviously if the data was static and not being added to with new spreadsheets then I could do a Vlockup or similar, but I’m sure there is a way to do this where it just looks for all spreadsheets within a folder.

Hopefully someone can help me with this please.

Thanks in advance

 

[NdNoviceHlp]

Adjusted for new requirements. Please fully outline your desired outcome when posting. Often, further requirements may need a completly different coding approach (ie. The initially posted code was a waste of time.) Anyways, here's the adjusted code to meet your new requirements. I should have mentioned that yes U do have to change the folder address and I should have more fully commented the code. This is sheet code. Call/Run FsoCycleThroughFiles2 macro to operate. HTH. Dave

Option Explicit
Sub FsoCycleThroughFiles2()
Dim Foldername As String, Cnt As Integer
Dim Filename As Object, FSO As Object
On Error GoTo ErrorHandler
'adjust foldername to suit
Foldername = "Z:\Graphite phase 2\Graphite 2.5 Test Folder\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
'data starts on row 2
Cnt = 1
'loop files in folder
For Each Filename In FSO.getfolder(Foldername).Files
'open only xlsx files
'**change file extension to suit
If Right(Filename.Name, 4) = "xlsx" Then
Workbooks.Open (Filename)
Cnt = Cnt + 1
'A2:whatever = B1 of all wbs in folder
ThisWorkbook.Sheets("Sheet1").Cells(Cnt, 1) = _
  ActiveWorkbook.Sheets("Sheet1").Range("B" & 1).Value
'B2:whatever = C1 of all wbs in folder
ThisWorkbook.Sheets("Sheet1").Cells(Cnt, 2) = _
  ActiveWorkbook.Sheets("Sheet1").Range("C" & 1).Value
'close wb
ActiveWorkbook.Close savechanges:=False
End If
Next Filename
Set FSO = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub

ErrorHandler:
MsgBox "An error occurred"
End Sub

 

[NdNoviceHlp]

Seems like I missed the Tracker 2.5 sheet name and the clear sheet thing requirements. If the looped wbs sheet name is not "sheet1" then this will also have to be adjusted.

Option Explicit
Sub FsoCycleThroughFiles2()
Dim Foldername As String, Cnt As Integer
Dim Filename As Object, FSO As Object
On Error GoTo ErrorHandler
'adjust foldername to suit
Foldername = "Z:\Graphite phase 2\Graphite 2.5 Test Folder\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
'data starts on row 2
'!!! CAUTION clears all cells
ThisWorkbook.Worksheets("Tracker 2.5").Cells.ClearContents
Cnt = 1
'loop files in folder
For Each Filename In FSO.getfolder(Foldername).Files
'open only xlsx files
'**change file extension to suit
If Right(Filename.Name, 3) = "xls" Then
Workbooks.Open (Filename)
Cnt = Cnt + 1
'A2:whatever = B1 of all wbs in folder
ThisWorkbook.Sheets("Tracker 2.5").Cells(Cnt, 1) = _
  ActiveWorkbook.Sheets("Tracker 2.5").Range("B" & 1).Value
'B2:whatever = C1 of all wbs in folder
ThisWorkbook.Sheets("Tracker 2.5").Cells(Cnt, 2) = _
  ActiveWorkbook.Sheets("Sheet1").Range("C" & 1).Value
'close wb
ActiveWorkbook.Close savechanges:=False
End If
Next Filename
Set FSO = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub

ErrorHandler:
MsgBox "An error occurred"
End Sub

 

[Darren Bartrup]

1) How do I make the data start in Column A2 rather than A1?
Yep, changing that code will do it.

2) What order does it decide to look at the files in the folder and drag the data through. Basically the files are called book1 through 4 at the moment but it drags the data through in the order 4,2,1,3 rather than 1,2,3,4? Is there a way to amend this?
When I tested it on a few folders in my computer it seemed to be pulling them through in alphabetical order, but that wasn't the case for you - so not sure.

3) Now this data at present drags through cell B1 from my data sheets in to column “A”. I am now wanting for it to drag through data for cell C1 also to sit in my “B” column. Do I simply add this code all over again and change the cell to C1 rather than B1?
No need to add the code again for the second cell.

This line of code takes one cell in row 2, column 2 ( .Cells(2,2) which can be written as .Range("B2") ) and puts it into another single cell ( row = lcol, column = 1).

.Cells(lcol, 1) = wrkBk.Worksheets(1).Cells(2, 2)

So we just need to update that line to take the values from two cells (which are always in the same place) and put it into column A & B of the whichever row.
So update where it gets it's values from (now Range("B2:C2") ) and resize where it needs to put the values to two columns wide (as shown by Resize(,2)). I've also put .Value after the range references so it copies the value rather than formula - it won't carry over cell formatting though.

.Cells(lcol, 1).Resize(, 2).Value = wrkBk.Worksheets(1).Range("B2:C2").Value

 

[ExcelAmateur2014]

thanks

the problem is that this seems to bring through a range rather than specified cells.

I want to be able to drag through data from specified cells into each column.

Eg

Column 1 - brings through data from cell "B1" of all the sheets in the folder
Column 2 - brings through data from cell "D1" of all the sheets in the folder
Column 3 - brings through data from cell "G3" of all the sheets in the folder

is that possible?

 

[Darren Bartrup]

Yes, it did pull through a range - you asked for B1 & C1 which are next to each other, so pulled it through as a range.

To pull individual cell values through change:

.Cells(lcol, 1).Resize(, 2).Value = wrkBk.Worksheets(1).Range("B2:C2").Value

to

.Cells(lcol, 1) = wrkBk.Worksheets(1).Cells(1, 2) 'Get B1 and put in col A.
.Cells(lcol, 2) = wrkBk.Worksheets(1).Cells(1, 4) 'Get D1 and put in col B.
.Cells(lcol, 3) = wrkBk.Worksheets(1).Cells(1, 7) 'Get G1 and put in col C.
.Cells(lcol, 8) = wrkBk.Worksheets(1).Cells(1, 16325) 'Get XCW1 and put in col H.

Just add as many as you want.

It could also be written as:

.Cells(lcol, 1) = wrkBk.Worksheets(1).Range("B1")
.Cells(lcol, 2) = wrkBk.Worksheets(1).Range("D1")
.Cells(lcol, 3) = wrkBk.Worksheets(1).Range("G1")
.Cells(lcol, 8) = wrkBk.Worksheets(1).Range("XCW1")

Just to clarify - this will pull back the values from the first sheet in each workbook in the folder.
You're asking for all sheets within a folder - do you mean sheets (tabs) within a workbook (file) or workbooks within a folder?

If you want each sheet within a file the code will need changing a bit.

 

[ExcelAmateur2014]

Thank you both so much its really appreciated

 

[ExcelAmateur2014]

just one other point that has arisen from the piece of work. All cells are going to be constant but the data sheets (templates that feed the main spreadsheet) will have 2 worksheets within them with data. How would I get it to look at the specified cell in different sheets as at the moment it just points to "sheet 1", so how could I for example get it to look up cells A1 and C3 in "sheet 1" and then cells B2 and D2 in "sheet 2".

Thank you again guys

 

[NdNoviceHlp]

Several things... I think you loop files in folders based on the folder option settings... Select view then "sortby" with the folder open to change how they output. They loop through the order of there presentation. I think the Worksheets(1) designation is working and was useful being that initially the sheet name (Sheet1) was unknown. The (1) refers to XL's internal counter and is not necessarily "Sheet1". So naming the sheet in code may be better. As I suspected when I first posted there was going to be further expanded requirements. Here's my final up to date post being that I screwed up the last post with a file search for "xls" rather than the required "xlsm". Trial it once. Darren has offerred some great help and I'll leave you to it. Good luck. Dave

Option Explicit
Sub FsoCycleThroughFiles2()
Dim Foldername As String, Cnt As Integer
Dim Filename As Object, FSO As Object
On Error GoTo ErrorHandler
'adjust foldername to suit
Foldername = "Z:\Graphite phase 2\Graphite 2.5 Test Folder\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
'data starts on row 2
'!!! CAUTION clears all cells
ThisWorkbook.Worksheets("Tracker 2.5").Cells.ClearContents
Cnt = 1
'loop files in folder
For Each Filename In FSO.getfolder(Foldername).Files
'open only xlsx files
'**change file extension to suit
If Right(Filename.Name, 4) = "xlsm" Then
Workbooks.Open (Filename)
Cnt = Cnt + 1
'A2:whatever = A1 of all wbs in folder
ThisWorkbook.Sheets("Tracker 2.5").Cells(Cnt, 1) = _
  ActiveWorkbook.Sheets("Tracker 2.5").Range("A" & 1).Value
'B2:whatever = C3 of all wbs in folder
ThisWorkbook.Sheets("Tracker 2.5").Cells(Cnt, 2) = _
  ActiveWorkbook.Sheets("Sheet1").Range("C" & 3).Value
'C2:whatever = B2 of all wbs in folder
ThisWorkbook.Sheets("Tracker 2.5").Cells(Cnt, 3) = _
  ActiveWorkbook.Sheets("Sheet2").Range("B" & 2).Value
'D2:whatever = D2 of all wbs in folder
ThisWorkbook.Sheets("Tracker 2.5").Cells(Cnt, 4) = _
  ActiveWorkbook.Sheets("Sheet2").Range("D" & 2).Value
'close wb
ActiveWorkbook.Close savechanges:=False
End If
Next Filename
Set FSO = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub

ErrorHandler:
MsgBox "An error occurred"
End Sub

 

[Darren Bartrup]

Sorry didn't reply early - been getting festive.

Right, if you want to copy from different sheets or paste to different sheets....

These lines of code get the data from a cell and puts it into a different cell:

.Cells(lcol, 1) = wrkBk.Worksheets(1).Cells(1, 2)[\code]

The bit after the equals sign is where it's getting the information from.

wrkBk is the reference to the file (or workbook)
Worksheets(1) is the reference to the sheet.
Cells(1,2) is the reference to the cell.

To look at a different sheet just change the Worksheets(1) part.
For the second sheet you would use Worksheets(2) - keep in mind with this that sheets can be rearranged by the user, so the second sheet may not always be the one you want.

You can also refer to a sheet by its name as it appears on the tab at the bottom of the screen using Worksheets("WorkSheetName") 

Remember to lock your workbook so the user can't change the name of the worksheets.

So to sum up:

	
	
	
	
	
	



	
	

		
.Cells(lcol, 1) = wrkBk.Worksheets(1).Cells(1, 2)
.Cells(lcol, 2) = wrkBk.Worksheets(2).Cells(1,2)
.Cells(lcol, 3) = wrkBk.Worksheets("Some Other Sheet").Range("A2")
	

Now, you may want to get information from all sheets in a workbook and the number of sheets may change, or there may be too many sheets to want to write out the code for each sheet.
In this case you can step through the collection of sheets held in the workbook (remember collections - they come in very useful when coding)

First you'll need a new variable to hold the reference to the worksheet.
Add it at the top of the procedure:

	
	
	
	
	
	



	
	

		
Dim wrkSht as WorkSheet
	

You need a bit of code to step through each sheet in the WorkSheets collection

	
	
	
	
	
	



	
	

		
For Each wrkSht in wrkBk.WorkSheets
	

Then get the information from the wrkSht variable.  Where before we used wrkBk.Worksheets(1) we can now use:

	
	
	
	
	
	



	
	

		
.Cells(lcol, 1) = wrkSht.Cells(1, 2)
	

Finally we have to tell Excel to move on to the next sheet in the workbook:

	
	
	
	
	
	



	
	

		
Next wrkSht
	

So instead of:

	
	
	
	
	
	



	
	

		
.Cells(lcol, 1) = wrkBk.Worksheets(1).Cells(1, 2) 'Get B1 and put in col A.
.Cells(lcol, 2) = wrkBk.Worksheets(1).Cells(1, 4) 'Get D1 and put in col B.
.Cells(lcol, 3) = wrkBk.Worksheets(1).Cells(1, 7) 'Get G1 and put in col C.
.Cells(lcol, 8) = wrkBk.Worksheets(1).Cells(1, 16325) 'Get XCW1 and put in col H.
	

we can use:
	
	
	
	
	
	



	
	

		
For Each wrkSht in wrkBk.WorkSheets
                .Cells(lcol, 1) = wrkSht.Cells(1, 2) 'Get B1 and put in col A.
                .Cells(lcol, 2) = wrkSht.Cells(1, 4) 'Get D1 and put in col B.
                .Cells(lcol, 3) = wrkSht.Cells(1, 7) 'Get G1 and put in col C.
                .Cells(lcol, 8) = wrkSht.Cells(1, 16325) 'Get XCW1 and put in col H.
                lcol = lcol + 1
Next wrkSht
	

And it will get those values from every sheet in the workbook.  You'll have to increase the value lcol as well or it will paste the values into the same cells - overwriting the previous value each time.

 

[ExcelAmateur2014]

Hi thanks for this and hope you have a great xmas.

I have developed the code to the following, yet now it only brings through the data from one spreadsheet in the folder and doesn't look to then look at the other one in the folder for some reason. It some how only brings through one line of data.

I cant figure out what I am missing.

Public Sub Main()


Dim vFolder As Variant
Dim vFile As Variant
Dim colFiles As Collection
Dim wrkBk As Workbook
Dim wsFrom As Worksheet, wsTo As Worksheet
Dim lcol As Long, rowNum As Long
Dim rng As Range
Dim rngFrom As Range, rngTo As Range
Dim correctSS As Boolean


'Ask for the folder location.
vFolder = GetFolder("Z:\Graphite phase 2\Graphite 2.5 Test Folder")

rowNum = 4

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wsTo = ThisWorkbook.Worksheets("Sheet1")

If vFolder <> "" Then

'Get all Excel files from within folder.
Set colFiles = New Collection
EnumerateFiles vFolder, "*.xls*", colFiles

ThisWorkbook.Worksheets("Sheet1").Cells.ClearContents

For Each vFile In colFiles

correctSS = False

'Open the workbook without updating links.

Set wrkBk = Workbooks.Open(CStr(vFile), False)

correctSS = checkWSandRange(wrkBk, "hide_DATA", "rImport")

If correctSS Then
Set wsFrom = wrkBk.Worksheets("hide_DATA")
Set rngFrom = wsFrom.Range("rImport")

'error trapping....

Set rngTo = Range(wsTo.Cells(rowNum, 1), wsTo.Cells(rowNum, 478))

rngTo.value = rngFrom.value

lcol = lcol + 1

End If

'Close the workbook without saving.
wrkBk.Close False
Next vFile
End If

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

Private Function checkWSandRange(ByRef theWB As Workbook, ByVal theWSname As String, ByVal theNamedRange As String) As Boolean

Dim ws As Worksheet
Dim rangeName As Name
Dim valToReturn As Boolean

valToReturn = False

For Each ws In theWB.Worksheets
If ws.Name = theWSname Then
For Each rangeName In theWB.Names
If rangeName.Name = theNamedRange Then
valToReturn = True
Exit For
End If
Next
End If
If valToReturn Then Exit For
Next ws

checkWSandRange = valToReturn

End Function


'---------------------------------------------------------------------------------------
' Procedure : GetFolder
' Purpose : Returns the file path of the selected folder.
' To Use : vFolder = GetFolder()
'---------------------------------------------------------------------------------------
Function GetFolder(Optional startFolder As Variant = -1) As Variant
Dim fldr As FileDialog
Dim vItem As Variant
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFolder = vItem
Set fldr = Nothing
End Function


'----------------------------------------------------------------------------------
' Procedure : EnumerateFiles
' Purpose : Places all file names with FileSpec extension into a collection.
' To Use : EnumerateFiles "S:\Bartrup-CookD\Trackers", "*.xls", colFiles
'-----------------------------------------------------------------------------------
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)


Dim sTemp As String

If InStrRev(sDirectory, "\") <> Len(sDirectory) Then
sDirectory = sDirectory & "\"
End If

sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub