basic excel 2003 macro no longer works in excel 2007

[umy]

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-comfficeffice" /><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

 

[Trevor G]

Welcome to the Forum,

Have you checked your setttings for Enabling macros? Use teh Office Button top left of the screen, then Excel Options bottom right then

Then the Trust center then Trust Cneter settings then MACRO Settings you might have a default to disable all macros

 

[Andrew Poulsom]

FileSearch has been deprecated in Excel 2007. You will need to use the Dir function in a loop:

http://www.mrexcel.com/forum/showthread.php?t=268046

 

[umy]

Excellent, thank you

Can anyone help my editing the few lines in my code to do this? I have now idea i'm afraid

 

[Andrew Poulsom]

Try the untested:

Sub Get_Value_From_All()
    Dim wbSource As Workbook
    Dim wbThis As Workbook
    Dim rToCopy As Range
    Dim rNextCl As Range
    Dim strPath As String
    Dim FileName As String
    Dim bHeaders As Boolean
    Dim n As Long
    Dim i As Long
    Dim wsFrom As Worksheet
    Dim wsTo As Worksheet
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        On Error Resume Next
        Set wbThis = ThisWorkbook
        strPath = "C:\newtest\"
        FileName = Dir(strPath & "*.xls")
        Do While FileName <> ""
'           Open Workbook x and Set a Workbook variable to it
            Set wbSource = Workbooks.Open(FileName:=strPath & FileName, 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
            FileName = Dir    ' Get next entry.
        Loop
        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
        On Error GoTo 0
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

 

[umy]

Hi

Thank you for that.

The good news is that it didn't cause any errors.

The bad news is that it didn't actually do anything. It only copied a random number "1" into the sheet which i ran the macro from, didn't bring across anything else at all. In fact, I'm not even sure where it got the "1" from?

Please persevere...

 

[Andrew Poulsom]

Do you get an error if you comment out this line?

On Error Resume Next

 

[umy]

Ok, did a bit more research after commenting out the line you suggested.

When I left the original xls files in the foler, I would get an object undefined error and no data would be copied across. It would be blank in the macro sheet, but i noticed that it was running in compatibility mode.

I then opened the data xls files and saved them as xlsx files. The data did now get copied across, but the first column, which contains numbers, is blank - I also noticed that it generates a "subscript out of range" error on the open sheet. It also loses all formatting etc.
I remember that the original guy who was helping me out with this had to do something special in the macro to autonumber the first column or something, maybe this is causing the error???


I am not able to upload any attachments here, but if you let me have your email, then I am happy to email you the test sheets to see if you can make sense of them?

Once again, many thanks for all your help!

 

[Andrew Poulsom]

Which line of code cause the subscript out of range error?

This is doing the numbering:

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

I would expect at least to see a 1 in A3. The numbers should extend to the last filled row in column B.

 

[umy]

Hi there

It doesn't actually show me the line which contains the error, i don't get a debug option, only the fact that it "Runtime error "9" - Subscript out of range". Also, the whole of column A is blank, absolutely nothing there.

It would be good to get some sort of robust solution again, as saving all of the sheets as xlsx will be very time consuming indeed, there are quite a few when we run the actual macro.

once again, thank you for all your help so far

You can see the orginal posts from the guy who helped me create this at the below forum :
http://www.ozgrid.com/forum/showthread.php?t=145384&page=3