Excel 2003導入宏在Excel 2010中不起作用

Question

我有一個宏，用於從目錄中的許多Excel工作簿導入數據。它在Excel 2003中工作得很好，但是由於我最近升級到Excel 2010，宏似乎不起作用。當被激活時，宏不會出錯或產生任何東西。我已經更改了所有信任中心設置和我擁有的其他宏（不導入數據宏）。我不擅長編寫VBA，也不知道問題可能出在哪裏。它只是看起來像excel trys運行宏並跳過它曾經做過和完成的一切。任何幫助是極大的讚賞。謝謝

Sub GDCHDUMP() 
Dim lCount As Long 
Dim wbResults As Workbook 
Dim twbk As Workbook 


Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.EnableEvents = False 

On Error Resume Next 
Set twbk = ThisWorkbook 
    With Application.FileSearch 
    .NewSearch 
    'Change path to suit 
    .LookIn = "R:\ServCoord\GCM\Data Operations\Quality\GDCHDump" 
    .filename = "*.xls*" 
    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 wbResults = Workbooks.Open(filename:=.FoundFiles(lCount), UpdateLinks:=0) 
     Set ws = wbResults.Sheets(1) 
     ws.Range("B2").Copy 
     twbk.Sheets(1).Cells(lCount, 1).PasteSpecial xlPasteValues 
     wbResults.Close SaveChanges:=False 
     'There was a lot more lines like the 2 above that I removed for clarity 
     Next lCount 
    End If 
End With 
On Error GoTo 0 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.EnableEvents = True 
End Sub 

Answer 1

On Error Resume Next應該真的迴避，除非需要。這就像告訴Excel到Shut Up。 的主要問題是，Application.FileSearch不supported在XL2007 +

可以使用Application.GetOpenFilename代替。

看到這個例子。 （UNTESTED）

Option Explicit 

Sub GDCHDUMP() 
    Dim lCount As Long 
    Dim wbResults As Workbook, twbk As Workbook 
    Dim ws As Worksheet 
    Dim strPath As String 
    Dim Ret 
    Dim i As Long 

    strPath = "R:\ServCoord\GCM\Data Operations\Quality\GDCHDump" 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 

    Set twbk = ThisWorkbook 

    ChDir strPath 
    Ret = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True) 

    If TypeName(Ret) = "Boolean" Then Exit Sub 

    For i = LBound(Ret) To UBound(Ret) 
     Set wbResults = Workbooks.Open(Filename:=Ret(i), UpdateLinks:=0) 
     Set ws = wbResults.Sheets(1) 
     ws.Range("B2").Copy 
     'twbk.Sheets(1).Cells(lCount, 1).PasteSpecial xlPasteValues 
     wbResults.Close SaveChanges:=False 
    Next i 

    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
End Sub