Name of the file inside the excel file cell using VBA - 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