将文件名从多个工作簿复制到另一个工作簿中的单元格

我有一个文件夹有很多的工作簿，我需要将文件名（和其他一些数据）复制到主工作簿。 我发现了一个代码来导入数据，但似乎无法导入文件名。

在“>>> >>>>>适应这个部分后”我试图写一些代码来复制和粘贴文件名，但似乎没有工作。

我使用“'>>>>>>适应此部分”复制一些其他数据，所以我只需要一些代码，以适应insted我的不工作的代码:)部分

Sub Import_to_Master() Dim sFolder As String Dim sFile As String Dim wbD As Workbook, wbS As Workbook Application.ScreenUpdating = False Set wbS = ThisWorkbook sFolder = wbS.Path & "\" sFile = Dir(sFolder) Do While sFile <> "" If sFile <> wbS.Name Then Set wbD = Workbooks.Open(sFolder & sFile) ' >>>>>> Adapt this part WName = ActiveWorkbook.Name WName.Copy Sheets("Combined").Range("N" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues Application.CutCopyMode = False ' >>>>>> wbD.Close savechanges:=True 'close without saving End If sFile = Dir 'next file Loop Application.ScreenUpdating = True End Sub 

Answer 1

 Sub Import_to_Master() Dim sFolder As String Dim sFile As String Dim wbD As Workbook, wbS As Workbook Application.ScreenUpdating = False Set wbS = ThisWorkbook sFolder = wbS.Path & "\" sFile = Dir(sFolder) Do While sFile <> "" If sFile <> wbS.Name Then Set wbD = Workbooks.Open(sFolder & sFile) ' >>>>>> Adapt this part wbS.Sheets("Combined").Range("N" & wbS.Sheets("Combined").Rows.Count).End(xlUp).Offset(1, 0).Value = sFile ' >>>>>> wbD.Close savechanges:=True 'close without saving End If sFile = Dir 'next file Loop Application.ScreenUpdating = True End Sub 

Answer 2

您可以直接使用对象wbD及其属性.Name 。

为了更好的可读性，我还添加了对Sheet（“Combined”）的引用：

 Sub Import_to_Master() Dim sFolder As String Dim sFile As String Dim wbD As Workbook, wbS As Workbook Dim wSc As Worksheet Application.ScreenUpdating = False Set wbS = ThisWorkbook '''Define the sheet Set wSc = wbS.Sheets("Combined") sFolder = wbS.Path & "\" sFile = Dir(sFolder) Do While sFile <> "" If sFile <> wbS.Name Then Set wbD = Workbooks.Open(sFolder & sFile) ' >>>>>> Adapt this part wSc.Range("N" & wSc.Rows.Count).End(xlUp).Offset(1, 0).value = wbD.Name ' >>>>>> wbD.Close savechanges:=True 'close without saving End If sFile = Dir 'next file Loop Application.ScreenUpdating = True End Sub