Application.FileDialog(msoFileDialogFolderPicker)无法打开指定路径

aimeiyun

求大神指点：
Application.FileDialog(msoFileDialogFolderPicker)无法打开指定路径，每次都是默认我的文档，而msoFileDialogfilePicker可以打开指定路径，是否遗漏了什么步骤？
Sub Collectwk2()
    Dim Trow&, k&, arr, brr, i&, j&, book&, a&
    Dim p$, f$, Rng As Range
    With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
      .Title = "请选择要搜索的文件夹"
      .InitialFileName = "G:\"
        If .Show Then p = .SelectedItems(1) Else Exit Sub
    End With
    If Right(p, 1) <> "\" Then p = p & "\"
    '
    Trow = 6 'Val(InputBox("请输入标题的行数", "提醒"))替换为1
    If Trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
    Application.ScreenUpdating = False '关闭屏幕更新
    Cells.ClearContents '清空当前表数据
    Cells.NumberFormat = "@" '设置单元格格式为文本
    ReDim brr(1 To 200000, 1 To 1)
    '定义装汇总结果的数组brr，最大行数为20万行
    f = Dir(p & "手淘搜索*.xls*")
    '开始遍历指定文件夹路径下的指定的工作簿
    Do While f <> ""
        If f <> ThisWorkbook.Name Then '避免同名文件重复打开出错
            With Workbooks.Open(p & f)
            '以\'只读\'形式读取文件时，使用getobject方法会比workbooks.open稍快
                Set Rng = .Sheets(1).UsedRange
                If IsEmpty(Rng) = False Then '如果工作表非空
                    book = book + 1 '标记一下是否首个Sheet,如果首个sheet，BOOK=1
                    a = IIf(book = 1, 1, Trow + 1) '遍历读取arr数组时是否扣掉标题行
                    arr = Rng.Value '数据区域读入数组arr
                    If UBound(arr, 2) > UBound(brr, 2) Then
                    '动态调整结果数组brr的最大列数，避免明细表列数不一的情况。
                        ReDim Preserve brr(1 To 200000, 1 To UBound(arr, 2))
                    End If
                    For i = a To UBound(arr) '遍历行
                        k = k + 1 '累加记录条数
                        For j = 1 To UBound(brr, 2) '遍历列
                            brr(k, j) = arr(i, j)
                        Next
                    Next
                End If
                .Close False '关闭工作簿，不保存。
            End With
        End If
        f = Dir '下一个工作簿
    Loop
    If k > 0 Then
        [a1].Resize(k, UBound(brr, 2)) = brr
        MsgBox "汇总完成。"
    End If
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub

microyip

没看出有什么问题

aimeiyun

microyip 发表于 2019-11-9 08:03
没看出有什么问题

谢谢microyip，我在WIN8,WIN7,WIN10上都运行了，都是一样，无法指定路径，打开只能默认我的文档，VBA也试了6,7,7.1版本，语法也没找出问题，搞不懂了

microyip

aimeiyun 发表于 2019-11-9 13:07
谢谢microyip，我在WIN8,WIN7,WIN10上都运行了，都是一样，无法指定路径，打开只能默认我的文档，VBA也试 ...

其实最大问题是没附件，估计是出在你的文件上

dragonripp

问题好像出在默认路径不存在上。

lele6809

特意测试了下，对话框确实可以指向 G:\，没问题