VBA遞歸函數僅從新文件中獲取數據。

Question

我使用遞歸函數從磁盤上的文件夾和子文件夾中的文件獲取特定數據。這些數據在我的Excel文件中保存爲一個新行並創建表。它工作正常。但是，如果我創建新文件並將其放入隨機子文件夾中，那麼在啓動遞歸函數後，我想將該數據添加爲之前創建的表中的新行。而不是刪除整個表，然後重複啓動遞歸函數並獲取表中的數據。

類似刷新按鈕 - 如果點擊它，它會檢查每個文件夾和子文件夾，如果找到一些新文件或文件，請將它們添加到表格的最後一行。

這是現在使用的代碼I'm：

Function Recurse(sPath As String) As String 

Dim FSO As New FileSystemObject 
Dim myFolder As Folder 
Dim mySubFolder As Folder 
Dim myFile As File 
Dim erow 
Dim Black 
Dim cislokabla 

Set myFolder = FSO.GetFolder(sPath) 

For Each mySubFolder In myFolder.SubFolders 
    For Each myFile In mySubFolder.Files 


    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 

GetData myFile, "Sheet1", _ 
"F1:F2", Sheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 1)), True, False 

Black = Sheet1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row 

GetData myFile, "Sheet1", _ 
"O4:O5", Sheets("Sheet1").Range(Cells(Black, 2), Cells(Black, 2)), True, False 

cislokabla = Sheet1.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row 

GetData myFile, "Sheet1", _ 
"AH1:AH2", Sheets("Sheet1").Range(Cells(Black, 3), Cells(Black, 3)), True, False 






    Next 
    Recurse = Recurse(mySubFolder.Path) 
Next 

End Function 

Sub nacitavaniedat() 

Call Recurse("\\Sk-wftkabel\public\Identifikačné listy káblov\káble\") 


End Sub 

Answer 1

你需要命名爲 「Sheet2的」 Sheet2中，以文件名:) 存儲（改變14年1月30日）

Sub Recurse() 
Dim FSO As New FileSystemObject 
Dim myFolder As Scripting.Folder, mySubFolder As Scripting.Folder 
Dim myFile As File 
Dim sPath$: sPath = "\\Sk-wftkabel\public\Identifikacne listy kablov\kable\" 
Dim R$ 
R = Join(Application.Transpose(Sheets("Sheet2").UsedRange), "|") 
Set myFolder = FSO.GetFolder(sPath) 
For Each mySubFolder In myFolder.SubFolders 
    For Each myFile In mySubFolder.Files 
     DoEvents 
     If Not (InStr(1, R, myFile.Path) > 0) Then 
      GetData myFile, "Sheet1", "F1:F2", Sheets("Sheet1").Range(Sheets(1).Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1), Sheets(1).Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)), True, False 
      GetData myFile, "Sheet1", "O4:O5", Sheets("Sheet1").Range(Sheets(1).Cells(Sheet1.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2), Sheets(1).Cells(Sheet1.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2)), True, False 
      GetData myFile, "Sheet1", "AH1:AH2", Sheets("Sheet1").Range(Sheets(1).Cells(Sheet1.Cells(Rows.Count, 3).End(xlUp).Row + 1, 3), Sheets(1).Cells(Sheet1.Cells(Rows.Count, 3).End(xlUp).Row + 1, 3)), True, False 
      Sheets("Sheet2").Cells(Sheets("Sheet2").UsedRange.Rows.Count + 1, 1).Value = myFile.Path 
      R = R & myFile.Path & "|" 
     End If 
    Next 
Next 
Set FSO = Nothing 
Set myFolder = Nothing 
Set mySubFolder = Nothing 
Set myFile = Nothing 
End Sub 

Option Explicit 


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _ 
       SourceRange As String, TargetRange As Range, Header As Boolean, 
       UseHeaderRow As Boolean) 

' 30-Dec-2007, working in Excel 2000-2007 
Dim rsCon As Object 
Dim rsData As Object 
Dim szConnect As String 
Dim szSQL As String 
Dim lCount As Long 

' Create the connection string. 
If Header = False Then 
    If Val(Application.Version) < 12 Then 
     szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 
        "Data Source=" & SourceFile & ";" & _ 
        "Extended Properties=""Excel 8.0;HDR=No"";" 
    Else 
     szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
        "Data Source=" & SourceFile & ";" & _ 
        "Extended Properties=""Excel 12.0;HDR=No"";" 
    End If 
Else 
    If Val(Application.Version) < 12 Then 
     szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 
        "Data Source=" & SourceFile & ";" & _ 
        "Extended Properties=""Excel 8.0;HDR=Yes"";" 
    Else 
     szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
        "Data Source=" & SourceFile & ";" & _ 
        "Extended Properties=""Excel 12.0;HDR=Yes"";" 
    End If 
End If 

If SourceSheet = "" Then 
    ' workbook level name 
    szSQL = "SELECT * FROM " & SourceRange$ & ";" 
Else 
    ' worksheet level name or range 
    szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];" 
End If 

On Error GoTo SomethingWrong 

Set rsCon = CreateObject("ADODB.Connection") 
Set rsData = CreateObject("ADODB.Recordset") 

rsCon.Open szConnect 
rsData.Open szSQL, rsCon, 0, 1, 1 

' Check to make sure we received data and copy the data 
If Not rsData.EOF Then 

    If Header = False Then 
     TargetRange.Cells(1, 1).CopyFromRecordset rsData 
    Else 
     'Add the header cell in each column if the last argument is True 
     If UseHeaderRow Then 
      For lCount = 0 To rsData.Fields.Count - 1 
       TargetRange.Cells(1, 1 + lCount).Value = _ 
       rsData.Fields(lCount).Name 
      Next lCount 
      TargetRange.Cells(2, 1).CopyFromRecordset rsData 
     Else 
      TargetRange.Cells(1, 1).CopyFromRecordset rsData 
     End If 
    End If 

Else 
    MsgBox "No records returned from : " & SourceFile, vbCritical 
End If 

' Clean up our Recordset object. 
rsData.Close 
Set rsData = Nothing 
rsCon.Close 
Set rsCon = Nothing 
Exit Sub 

SomethingWrong: 
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _ 
     vbExclamation, "Error" 
On Error GoTo 0 

End Sub