ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 186|回复: 2

现有复制文件的代码基础上添加,是否成功的判断

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-3-31 19:31 | 显示全部楼层 |阅读模式
有一个代码,是根据Excel中单元格的内容,从一个文件夹复制到指定文件夹中,现在想在这个程序的基础上添加一个是否成功的判断。麻烦大神帮帮忙

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-3-31 19:32 | 显示全部楼层
Sub CopyFiles()
'    适合源文件夹及其子文件夹(多层文件夹)
    Dim a$(), b$(), n&, i%, j&, fso1 As Object, fol1 As Object, fol2 As Object, arr, pa1$, pa2$
    Set fol1 = CreateObject("Shell.Application").BrowseForFolder(0, "源文件夹", 0)
    If Not fol1 Is Nothing Then pa1 = fol1.Items.Item.Path Else MsgBox "源文件夹": Exit Sub
    Set fol2 = CreateObject("Shell.Application").BrowseForFolder(0, "目标文件夹", 0)
    If Not fol2 Is Nothing Then pa2 = fol2.Items.Item.Path Else MsgBox "目标文件夹": Exit Sub
    Set fso1 = CreateObject("Scripting.FileSystemObject")
    Call Fso(pa1, a, b, n)
    arr = Range("a2:a" & Range("a" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(arr)
        For j = 1 To n
            If b(j) Like arr(i, 1) & "*" Then
                If Not fso1.FileExists(pa2 & "" & b(j)) Then
                    fso1.CopyFile a(j), pa2 & ""
                    Exit For
                End If
            End If
        Next
    Next
    MsgBox "复制完毕!"
End Sub
Sub Fso(myPath$, arr$(), brr$(), n&, Optional ef$ = "*.*")
    Dim fld As Object, f As Object, fd As Object
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    For Each f In fld.Files
        If f.Name Like ef Then
            n = n + 1
            ReDim Preserve arr(1 To n)
            ReDim Preserve brr(1 To n)
            arr(n) = f.Path: brr(n) = f.Name
        End If
    Next
    For Each fd In fld.SubFolders
        Call Fso(fd.Path, arr, brr, n, ef)
    Next
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-3-31 19:32 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-4-7 15:53 , Processed in 1.602892 second(s), 24 queries , Gzip On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表