Name of the file inside the excel file cell using VBA

Question

I need a VBA where it updates the "name of the excel file" inside that particular "excel file". There are 12 files in the folder. The path for this folder is D:\\Amit. Name of those 12 files are "Cash Report as on 11-05-2017 0000Hrs" starting from Midnight (that's why 0000Hrs) and it increases by 2 hours making it 0200Hrs, 0400Hrs etc. We prepare these files daily after every 2 hours. Sometimes it does happen that we run the file after 3 hours making it 0500Hrs instead of 0400Hrs just after 0200Hrs. What I need is a VBA file which opens all these 12 files and in column A in the last row of each respective file, it mentions the name of that particular file. Eg. it should open all 12 files and then in the first file named Cash Report as on 11-05-2017, in the last row of column A of this file - it should mention the name of this particular file.

So if the VBA opened file "Cash Report as on 11-05-2017 0400Hrs" then in the last cell of the column A just after the text or data in the cell, using offset the very below blank cell should have the name of this file as "Cash Report as on 11-05-2017 0000Hrs". Likewise, need something like this for all the files which open up each individual file and update the respective file name inside the last row of column A.

I was trying some of the codes but it's still in bits and pieces.

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

Try This

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

Try something like this.

Assumptions:

• The Excel file name will be pasted always in the first Sheet - in case the specific sheets are naming always in the same way change lines Sheets(1) with Sheets("YourName")
• Every row in table from column A in Sheets(1) is not empty as I'm using COUNTA function (thx @Darren Bartrup-Cook)

Code:

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