如何在 GetOpenFilename打开的文件夹下新建一个文件夹

cbtaja

szcougar 发表于 2017-7-22 14:21
我是VBA新手.
这句 fso As New FileSystemObject  编译错误  用户定义类型未定义  怎么解决? 谢谢

请看清代码注释中的要求：

1. Sub test()
   
2. 
   
3. Dim fso As New FileSystemObject '需引用"Mircrosoft Scripting Runtime"
   
4. Dim fl, fld$, Targetfld$, TargetFile$
   
5. 
   
6. fl = Excel.Application.GetOpenFilename '获取指定文件的文件名
   
7. If fl <> False Then
   
8.     fld = fso.GetParentFolderName(fl) '获取所在文件夹全路径
   
9.     Targetfld = fld & "\新文件夹" '目标文件夹
   
10.     If Not fso.FolderExists(Targetfld) Then MkDir Targetfld '如果目标文件夹不存在则新建(方法一)
    
11. '    If Dir(Targetfld, vbDirectory) = "" Then MkDir Targetfld '如果目标文件夹不存在则新建(方法二)
    
12.     TargetFile = Targetfld & "" & fso.GetFileName(fl)
    
13.     If fso.FileExists(TargetFile) Then fso.DeleteFile TargetFile '或 VBA.Kill TargetFile '如果已经有同名同路径的文件存在,则先删除之。
    
14.     fso.MoveFile fl, TargetFile  '移动文件
    
15. End If
    
16. Set fso = Nothing
    
17. End Sub

复制代码

szcougar

谢谢! 我再试试!!!

凌空一羽

szcougar 发表于 2017-7-22 13:56
谢谢.  试运行了你改的这个但 新建的文件夹不是我选择图片的那个文件夹下而是excel文件所在的那个文件夹 ...

Sub 批量插图()
off = Application.Version
Dim ff
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
tr = ActiveCell.Row: tc = ActiveCell.Column
filetoopen = Application.GetOpenFilename("JPG Files (*.JPG), *.JPG", , , , True)
For Each ff In filetoopen
     Cells(tr, tc).Select
If Application.Version <> "11.0" Then
        ActiveSheet.Pictures.Insert(ff).Cut
         Cells(tr, tc).Select
        ActiveSheet.PasteSpecial Format:="图片 (JPEG)"
    Else
         ActiveSheet.Pictures.Insert(ff).Select
    End If
    t = fso.GetParentFolderName(ff)
    mp = t & "\移入"
    If Dir(mp, vbDirectory) = "" Then MkDir (mp)
    fso.GetFile(ff).Move mp & "\" & fso.GetFile(ff).Name
Cells(tr + 14, tc) = ff1
tc = tc + 60
If tc = 182 Then
tr = tr + 14
tc = 2
    End If
Next ff
Set fso = Nothing
    Application.CommandBars("Picture").Visible = False
End Sub

szcougar

cbtaja 发表于 2017-7-22 14:54
请看清代码注释中的要求：

新建文件夹有了但文件并未移动而是改了文件名, 不知哪句不对啊?

szcougar

凌空一羽 发表于 2017-7-22 15:27
Sub 批量插图()
off = Application.Version
Dim ff

完全达到需求了.!!!!!  非常感谢!!!

cbtaja

szcougar 发表于 2017-7-22 16:10
新建文件夹有了但文件并未移动而是改了文件名, 不知哪句不对啊?

代码给了你，自己“单步执行”一遍，好好看看每一步的结果，自己分析一下，不要只会做伸手党。

szcougar

cbtaja 发表于 2017-7-22 17:21
代码给了你，自己“单步执行”一遍，好好看看每一步的结果，自己分析一下，不要只会做伸手党。

是的. 谢谢指导!!