使用 VBA 的 excel 文件单元格内的文件名

Question

我需要一个 VBA 来更新特定“excel 文件”中的“excel 文件的名称”。文件夹中有 12 个文件。此文件夹的路径是 D:\Amit。这 12 个文件的名称是“Cash Report as on 11-05-2017 0000Hrs”，从午夜开始（这就是为什么 0000Hrs），它增加了 2 小时，使其成为 0200Hrs、0400Hrs 等。我们每 2 小时后每天准备这些文件。有时确实会发生我们在 3 小时后运行文件，使其成为 0500Hrs 而不是 0200Hrs 之后的 0400Hrs。我需要的是一个 VBA 文件，它打开所有这 12 个文件，并且在每个文件的最后一行的 A 列中，它提到了该特定文件的名称。 例如。它应该打开所有 12 个文件，然后在 2017 年 5 月 11 日的第一个名为 Cash Report 的文件中，在该文件 A 列的最后一行 - 它应该提到这个特定文件的名称。

因此，如果 VBA 打开文件“Cash Report as on 11-05-2017 0400Hrs”，那么在单元格中的文本或数据之后的 A 列的最后一个单元格中，使用偏移量非常下面的空白单元格应该有此文件的名称为“2017 年 11 月 5 日 0000 小时的现金报告”。同样，对于打开每个单独文件并更新 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(1) 更改为 Sheets("YourName")
• Sheets(1) 中 A 列的表格中的每一行都不为空，因为我正在使用 COUNTA 函数（感谢 @Darren Bartrup-Cook）

代码：

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