将文件名从 VBA 中的 DIR 写入单元格

Question

我在下面附加了宏，它循环遍历目录中的文件并将数据复制到主文件（宏来自运行）。我想要做的也是在主文件中写入数据已从中复制的文件的名称粘贴到列的顶部（单元格 E5）。

能否请您指教...

子 Import_Data()

' PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them

Dim WB As Workbook
Dim wbThis As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

Set wbThis = ActiveWorkbook

' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' Retrieve Target Folder Path From User
MsgBox "Please select Faro Scan Data Folder"

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

' In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

' Target File Extension (must include wildcard "*")
myExtension = "*.xls"

' Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

' Loop through each Excel file in folder
Do While myFile <> ""

    ' Set variable equal to opened workbook
    Set WB = Workbooks.Open(Filename:=myPath & myFile)

    ' Ensure Workbook has opened before moving on to next line of code
    DoEvents

    ' Copy data from target workbook....
    WB.Activate
    Application.CutCopyMode = False
    Range("D8:D377").Copy
    wbThis.Activate
    Sheets("Faro Scan Data").Select
    Range("E5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Application.CutCopyMode = False

    ' Insert column for next data set
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight

    ' Format column for new dataset
    Columns("I:I").Select
    Selection.Copy
    Columns("E:E").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    ' Close Workbook
    WB.Close SaveChanges:=False

    ' Ensure Workbook has closed before moving on to next line of code
    DoEvents

    ' Get next file name
    myFile = Dir
Loop

' Message Box when tasks are completed
MsgBox "Task Complete!"

   ResetSettings:
' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "Remeber to enter column headings!"

End Sub

Answer 1

"myFile"中好像存有你要的文件名。为确保请在此行添加打印

myFile = Dir(myPath & myExtension)
Debug.Print myfile

并检查输出是否确实是您想要的字符串。

尝试改变

Sheets("Faro Scan Data").Select
Range("E5").Select
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

到

Sheets("Faro Scan Data").Select
Range("E5").Value = myFile
Range("E6").Select
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

而且我不确定这一行应该做什么：

myPath = myPath

将文件名从 VBA 中的 DIR 写入单元格

Write Filename to cell from DIR in VBA

directory

excel

filenames

vba