2

ディレクトリ内の多くの Excel ワークブックからデータをインポートするために使用したマクロがあります。Excel 2003 では問題なく動作していましたが、最近 Excel 2010 にアップグレードしたため、マクロが動作しないようです。マクロをアクティブにすると、エラーが発生したり、何も生成されたりしません。セキュリティ センターの設定をすべて変更し、他のマクロ (データ マクロをインポートしていない) は問題なく動作します。私は VBA を書くのが苦手で、どこに問題があるのか​​わかりません。Excelがマクロを実行しようとして、一度行ったすべてをスキップして終了するようです。どんな助けでも大歓迎です。ありがとうございました

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
4

1 に答える 1

3

On Error Resume Next必要がない限り、本当に避けるべきです。エクセルに命令するようなものShut Upです。主な問題は、xl2007+ でサポートApplication.FileSearchされていないことです。

代わりに使用できますApplication.GetOpenFilename。

この例を参照してください。(未テスト)

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
于 2013-02-20T18:30:25.550 に答える