Hi Prometheus,
Removing a redundant variable and (attempting) to overcome a slight
line-wrap problem, try instead:
'==============
Sub Tester()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim rnum As Long
Dim CalcMode As Long
Dim i As Long
'Fill in the path\folder where the files are
MyPath = "C:\One" '"C:\Desktop\Data\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
rnum = 1
'Fill the array(myFiles)with the list of _
'Excel files in the folder
Fnum = 0
Do While FilesInPath < ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If Fnum 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
With basebook.Sheets(1)
.Cells(rnum, "A").Value = mybook.Name
.Cells(rnum, "B").Value = _
mybook.Sheets(1).Range("F12").Value
For i = 1 To 6
.Cells(rnum, "A").Resize(1, 2). _
Offset(0, 2 * i).Value = _
mybook.Sheets(1).Range("F12").Offset(i). _
Resize(1, 2).Value
Next i
End With
rnum = rnum + 1
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<==============
---
Regards,
Norman
"Norman Jones" wrote in message
...
Hi Prometheus,
I have tweaked the sequences, so try:
'==============
Sub Tester()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim rnum As Long
Dim CalcMode As Long
Dim i As Long
'Fill in the path\folder where the files are
MyPath = "C:\Desktop\Data\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
rnum = 1
'Fill the array(myFiles)with the list of _
'Excel files in the folder
Fnum = 0
Do While FilesInPath < ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If Fnum 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
With basebook.Sheets(1)
.Cells(rnum, "A").Value = mybook.Name
.Cells(rnum, "B").Value = _
mybook.Sheets(1).Range("F12").Value
For i = 1 To 6
.Cells(rnum, "A").Resize(1, 2). _
Offset(0, 2 * i).Value =
_
mybook.Sheets(1).Range("F12").Offset(i). _
Resize(1,
2).Value
Next i
End With
rnum = rnum + 1
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<==============
---
Regards,
Norman
"Prometheus" wrote in message
oups.com...
Norman,
The VB Code didn't quite work.
The resulting sheet was close to what was expected. But I think the
error came down to my example above which didn't leave me room to
exactly show what was required in a google groups posting.
The resulting file gave the format:
Sheetname|F12|F13|F14|F15|F16|F17|F18|G13|G14|G15| G16
Is it Possible to output in this format?
Sheetname|F12|F13|G13|F14|G14|F15|G15 and so on t
F13 onwards would ideally allternate with it's corresponding G.
Cheers
Prometheus.