I always used the below simple macro for combining data from multiple sheets into one and it worked a treat. However, we have now upgraded to from office 2003 to office 2007 and it has stopped working. Can you let me know what I need to change and if possible, maybe even make the change for me as my excel is as good as my Klingon, not very good at all J
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o
></o>
Thank you
<o></o>
<o></o>
Sub Get_Value_From_All()
<o></o>
Dim wbSource As Workbook
Dim wbThis As Workbook
Dim rToCopy As Range
Dim rNextCl As Range
Dim lCount As Long
Dim bHeaders As Boolean
Dim n As Long
Dim i As Long
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
<o></o>
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
<o></o>
On Error Resume Next
Set wbThis = ThisWorkbook
search:
With .FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\newtest\"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count ' Loop through all.
'Open Workbook x and Set a Workbook variable to it
Set wbSource = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
For i = 1 To wbSource.Worksheets.Count - 1
Set wsFrom = wbSource.Worksheets(i)
Set wsTo = wbThis.Worksheets(i)
Set rToCopy = wsFrom.Range("B2", wsFrom.Range("B" & Rows.Count).End(xlUp)).Resize(, 20)
Set rNextCl = wsTo.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
If rNextCl.Row > 2 Then
rToCopy.Offset(1, 0).Resize(rToCopy.Rows.Count - 1, rToCopy.Columns.Count).Copy rNextCl
'no headers so copy
Else
rToCopy.Copy wsTo.Range("B2")
End If
Next i
wbSource.Close False 'close source workbook
Next lCount
Else
MsgBox "No workbooks found"
End If
End With
<o></o>
For i = 1 To wbThis.Worksheets.Count - 1
With wbThis.Worksheets(i)
n = .Cells(Rows.Count, 2).End(xlUp).Row
.Range("A2:A" & n).ClearContents
.Range("A3").Value = 1
.Range("A3:A" & n).DataSeries , Type:=xlLinear, Step:=1
End With
Next i
<o></o>
On Error GoTo 0
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
<o></o>
End Sub
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o></o>Thank you
<o
></o><o
></o>Sub Get_Value_From_All()
<o
></o>Dim wbSource As Workbook
Dim wbThis As Workbook
Dim rToCopy As Range
Dim rNextCl As Range
Dim lCount As Long
Dim bHeaders As Boolean
Dim n As Long
Dim i As Long
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
<o
></o>With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
<o
></o>On Error Resume Next
Set wbThis = ThisWorkbook
search:
With .FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\newtest\"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count ' Loop through all.
'Open Workbook x and Set a Workbook variable to it
Set wbSource = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
For i = 1 To wbSource.Worksheets.Count - 1
Set wsFrom = wbSource.Worksheets(i)
Set wsTo = wbThis.Worksheets(i)
Set rToCopy = wsFrom.Range("B2", wsFrom.Range("B" & Rows.Count).End(xlUp)).Resize(, 20)
Set rNextCl = wsTo.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
If rNextCl.Row > 2 Then
rToCopy.Offset(1, 0).Resize(rToCopy.Rows.Count - 1, rToCopy.Columns.Count).Copy rNextCl
'no headers so copy
Else
rToCopy.Copy wsTo.Range("B2")
End If
Next i
wbSource.Close False 'close source workbook
Next lCount
Else
MsgBox "No workbooks found"
End If
End With
<o
></o>For i = 1 To wbThis.Worksheets.Count - 1
With wbThis.Worksheets(i)
n = .Cells(Rows.Count, 2).End(xlUp).Row
.Range("A2:A" & n).ClearContents
.Range("A3").Value = 1
.Range("A3:A" & n).DataSeries , Type:=xlLinear, Step:=1
End With
Next i
<o
></o>On Error GoTo 0
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
<o
></o>End Sub
