VBA循環來積累數據

Question

我有一個文件，我得到每天/每週。首先我測試目錄中是否有文件，如果不是那麼我去「數據跟蹤器」，並在該表中創建範圍B2「缺失」的值。我在這一節得到一個

運行時錯誤1004

。請幫忙。

如果該文件是可用的，那麼我需要複製打開工作簿的B2，我需要將其粘貼到我的微距書列A，如果列A已經有值，那麼它將在下一個可用粘貼/我的宏簿A列中的空單元格/行。該部分可能也是錯誤的，希望專家能夠提供幫助。

Application.AskToUpdateLinks = False 
Application.ScreenUpdating = False 

Dim FilePath As String 
Dim TestStr As String 

Dim WBA As Workbook 'Opened Workbook 


FilePath = "C:\Users\anthonyer\Documents\Automation VBA\Source\Comcast Secondary" 

TestStr = "" 
On Error Resume Next 
TestStr = Dir(FilePath) 
On Error GoTo 0 

If TestStr = "" Then  
    Workbooks("FullAuto Final.xlsm").Activate 
    Worksheets("Data Tracker").Range("B2").Select 
    Selection.Value = "Missing" 
Else 
    Workbooks.Open "C:\Users\anthonyer\Documents\Automation VBA\Source\Comcast Secondary" 

    Set WBA = ActiveWorkbook   
    WBA.Application.CutCopyMode = False 

    'Select and Copy Site Name 
    WBA.Sheets(1).Range("B2").Select 
    Range(Selection, Selection.End(xlDown)).Select 

    Selection.Copy Destination:=ThisWorkbook.Worksheets(1).Range("A:A" & Cells(Rows.Count, "A:A").End(xlUp).Row) 

    WBA.Close SaveChanges:=False 
    ThisWorkbook.Activate 
    Worksheets("Data Tracker").Range("A2").Value = "Complete" 

End If 

Application.AskToUpdateLinks = True 
Application.ScreenUpdating = True 

End Sub 

Answer 1

FilePath = "C:\Users\anthonyer\Documents\Automation VBA\Source\Comcast Secondary" 

TestStr = "" 
On Error Resume Next 
TestStr = Dir(FilePath) 
On Error GoTo 0 

此錯誤句柄的工作原理如下：如果存在與TestStr = DIR（文件路徑）錯誤，忽略它，在代碼前進。 正確的錯誤處理的工作是這樣的：

FilePath = "C:\Users\anthonyer\Documents\Automation VBA\Source\Comcast Secondary" 

TestStr = "" 
On Error GoTo ErrHandler 
TestStr = Dir(FilePath) 
On Error GoTo 0 

'Code if no Error occurs 
Exit Sub 

ErrHandler: 
'Code if Error occurs. 
Resume Next 'if you want to return to the code 
End Sub 

但是如果測試與錯誤處理程序存在的錯誤是相當醜陋。您可以使用FileSystemObject庫來測試該文件。爲此，您需要先激活它。轉至工具 - >參考並檢查Microsoft腳本運行時。

檢查文件。有這個庫提供一個整潔的方法：

Dim fsoFile as Scripting.FileSystemObject 

Set fsoFile = New Scripting.FileSystemObject 'Instancing 

If Not fsoFile.FileExists("C:\Users\anthonyer\Documents\Automation VBA\Source\Comcast Secondary") Then 

現在，你的運行時錯誤mostlikely通過工作表（「數據跟蹤」）製作有不能在工作表名稱的任何空格。而且，在VBA中從不需要選擇一個單元。再這樣下去，而不是：

Workbooks("FullAuto Final.xlsm").Worksheets("DataTracker").Range("B2").Value = "Missing" 

Else 
'Do other stuff if the file exists 
End if 
End sub 

Answer 2

嘗試下面編輯的代碼：

Sub OpenFileFolder() 


Dim WBA     As Workbook 'Opened Workbook 
Dim FilePath   As String 
Dim TestStr    As String 
Dim FileExtension  As String 
Dim lastRow    As Long 
Dim Rng     As Range 

Application.AskToUpdateLinks = False 
Application.ScreenUpdating = False 

FilePath = "C:\Users\anthonyer\Documents\Automation VBA\Source\Comcast Secondary\" 
FilePath = "C:\" 
' can modify it to filter only Excel files 
FileExtension = "*" 

TestStr = "" 
On Error Resume Next 
TestStr = Dir(FilePath & FileExtension) 
On Error GoTo 0 

' file found 
If Len(TestStr) > 0 Then 
    Set WBA = Workbooks.Open(Filename:=FilePath & TestStr) 

    WBA.Application.CutCopyMode = False 

    ' find last row in Column B in WBA Sheets(1) 
    lastRow = WBA.Sheets(1).Cells(WBA.Sheets(1).Rows.Count, "B").End(xlUp).Row 

    ' Set Range of cells to copy 
    Set Rng = WBA.Sheets(1).Range("B2:B" & lastRow) 

    Rng.Copy Destination:=ThisWorkbook.Sheets(1).Range("A" & ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Rows.Count, "A").End(xlUp).Row + 1) 

    WBA.Close (False) 
    ThisWorkbook.Activate 
    Worksheets("Data Tracker").Range("A2").Value = "Complete" 

Else ' file not found 
    Workbooks("FullAuto Final.xlsm").Worksheets("Data Tracker").Range("B2").Value = "Missing" 
End If 

Application.AskToUpdateLinks = True 
Application.ScreenUpdating = True 

End Sub