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