Copy/Paste information from multiple sheets

[GillyB]

Hi All, hope you're having a great day!

I am currently building a survey spreadsheet for an instructor. Yes I have informed them that there is many programs available for this task but nope, they want Excel.

So my plan is...

Main Spreadsheet called "Results" which the instructor keeps to himself
Survey Spreadsheet that auto-named when they submit the survey (this works perfectly so no problem there)

I want the "Results" spreadsheet to go into every sheet in the folder "Results" and copy the same range ("E4:E15") and then paste (and transpose) into a list in "Results".

Now, I have found code for this, however when I run it, it opens all the sheets and then nothing happens! I have looked through it but I cannot see where I am going wrong.

No error occurs, and also this is Excel 2003.

Any help would be MUCH appreciated as the lack of error and anything happening at all is making me go crazy-mad!

Here's the code:

Sub Transpose()

Range("A4:L200").Select
Selection.ClearContents


Dim spath As String
Dim sfile As String
Dim sht As Worksheet
Dim control As String
Dim nextrow As Long


'ROUTINE TO TRANSPOSE COLUMNS E4 to E15 INTO ROWS IN A MASTER SHEET


spath = ThisWorkbook.Path 'FILE PATH TO MASTER WORKBOOK
control = ThisWorkbook.Name 'DECLARE NAME OF MASTER WORKBOOK


nextrow = 2 'DICTATES WHERE TO START TRANSPOSING DATA - ROW TWO


With Application.FileSearch
.LookIn = spath & "\Results"
.Filename = ".xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then


Set newwkbk = ActiveWorkbook


For I = 1 To .FoundFiles.Count
Workbooks.Open (.FoundFiles(I))
sfile = ActiveWorkbook.Name


For Each sht In ActiveWorkbook.Worksheets


sht.Select


If Application.WorksheetFunction.CountA(Range("E4:E15")) > 0 Then 'CHECK TO ENSURE THERE IS DATA IN THE RANGE


Range("E4:E15").Select
Selection.Copy


'SWITCH TO MASTER SHEET
Workbooks(control).Activate
Sheets("Results").Select 'SELECT WORK SHEET THAT WILL CONTAIN DATA - RENAME ACCORDING TO YOUR SHEET!!
Cells(nextrow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
nextrow = nextrow + 1


End If


Workbooks(sfile).Activate 'SWITCH TO SOURCE DATA WORKBOOK


Next sht 'PROGRESS TO NEXT SHEET IN WORKBOOK


Workbooks(sfile).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close False


Next I
End If


End With


End Sub