使用VBA的Excel文件單元格內文件的名稱

Question

我需要一個VBA，它在那個特定的「excel文件」內更新「excel文件的名稱」。該文件夾中有12個文件。此文件夾的路徑是D：\ Amit。這12個文件的名稱是「從午夜開始的現金報告」（這就是爲什麼0000Hrs），並且它增加了2個小時使它成爲0200Hrs，0400Hrs等。我們每2小時後每天準備這些文件。有時候確實發生了，我們在3小時後運行該文件，使其在0500Hrs之後運行，而不是0200Hrs之後的0400Hrs。我需要的是一個VBA文件，它可以打開所有這12個文件，並在每個文件最後一行的A列中提到該特定文件的名稱。例如，它應該打開所有12個文件，然後在名爲Cash Report的第一個文件中顯示爲11-05-2017，在此文件的A列的最後一行中 - 應該提及此特定文件的名稱。

因此，如果VBA打開文件「Cash Report as on 11-05-2017 0400Hrs」，那麼在列A的最後一個單元格緊跟着單元格中的文本或數據之後，使用偏移量非常小的空白單元格應該有該文件的名稱爲「11-05-2017 0000Hrs的現金報告」。同樣，需要這樣的所有文件，打開每個單獨的文件，並更新列A的最後一行內的相應文件名。

我正在嘗試一些代碼，但它仍然是零散的。

Dim Source As String 
    Dim StrFile As String 

    'do not forget the last backslash in the source directory. 
    Source = "C:\Users\Admin\Desktop\VBA\" 
    StrFile = Dir(Source) 

    Do While Len(StrFile) > 0 
     Workbooks.Open Filename:=Source & StrFile 
     StrFile = Dir() 
    Loop 

    fldr = Activeworkbook.Path 
Dt = Application.InputBox("Enter Date as 'dd-mm-yyyy' ", format(Now," dd-mm-yyyy" 
Workbooks.open Filename:= fldr & "\Cash Report as on" & 0400 & "Hrs.xlsx" 
Range("A1").End(xlDown).Select 
Offset(1).Select 

Answer 1

嘗試這個

Sub t() 
    Dim Source As String 
    Dim StrFile As String 
    Dim wb As Workbook 

    'do not forget last backslash in source directory. 
    Source = "C:\Users\Admin\Desktop\VBA\" 
    StrFile = Dir(Source) 

    Do While Len(StrFile) > 0 
     Set wb = Workbooks.Open(Source & StrFile) 
     wb.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = wb.Name 
     StrFile = Dir() 
     wb.Close (True) 
    Loop 

End Sub 

Answer 2

嘗試這樣的事情。

假設：

• Excel文件名稱將在第一頁總是粘貼 - 的情況下，具體的牀單總是以同樣的方式改變線與Sheets("YourName")
• 每一行從命名Sheets(1)表在表（1）A列不爲空，因爲我使用COUNTA函數（THX @Darren Bartrup庫克）

代碼：

Sub InsertFileName() 

Dim strFolderPath As String 
Dim lngLastRow As Long 
Dim FileName As String 
Dim WorkBk As Workbook 
Dim ErrNumbers As Integer 

'Choose folder with Excel files 
strFolderPath = GetFolder(ThisWorkbook.Path) & "\" 

'Loop through all Excel files in FolderPath 
FileName = Dir(strFolderPath & "*.xl*") 
Do While FileName <> "" 

    'Open Excel file 
    Set WorkBk = Workbooks.Open(strFolderPath & FileName) 

    'Find the last row in A column 
    On Error Resume Next 
    lngLastRow = Application.WorksheetFunction.CountA(WorkBk.Sheets(1).Range("A:A")) + 1 
    If lngLastRow = 1 Then 
     ErrNumbers = ErrNumbers + 1 
     Err.Clear 
     GoTo NextWkb 
    End If 

    WorkBk.Sheets(1).Range("A" & lngLastRow).Value = WorkBk.Name 
NextWkb: 
     'Close file and save changes 
     WorkBk.Close True 
     'Next file 
     FileName = Dir() 
    Loop 

If ErrNumbers <> 0 Then 
    MsgBox "There were some problems with Excel files. Check if there is some empty sheet or empty A column in one or more Excel files and try again" 
Else 
    MsgBox "Everything went fine!" 
End If 


End Sub 


Function GetFolder(strPath As String) As String 
Dim fldr As FileDialog 
Dim sItem As String 
Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
With fldr 
    .Title = "Select a Folder" 
    .AllowMultiSelect = False 
    .InitialFileName = strPath 
    If .Show <> -1 Then GoTo NextCode 
    sItem = .SelectedItems(1) 
End With 
NextCode: 
GetFolder = sItem 
Set fldr = Nothing 
End Function