如何利用VBA进行文件的分发

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-18 14:57
只是作提示用，你把消息框表达式删除也没有关系的，就是直接退出sub，但并不建议这样做，有异常要及时弹 ...

老师，我想增加一个功能。
如1.excel文件在C盘，但是我想将他分发到d盘某文件下
2.添加一个我可以选择分发文件的来源，和分发的去向的选择。
不知道这样可以实现吗？

一把小刀闯天下

'只是增加了一个选择源数据文件夹的弹出框，这个目标文件夹名称不一定是“分发库”

Option Explicit

Sub test4()
  Dim arr, pth, filename(), dic(1), i, t, p, f
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then pth = .SelectedItems(1) Else Exit Sub
  End With
  t = Split(pth, "\")
  pth = Left(pth, Len(pth) - Len(t(UBound(t))))
  If Not getfilename(filename, pth & t(UBound(t)), ".pdf") Then MsgBox "!!": Exit Sub
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = [a1].CurrentRegion.Offset(1).Resize(, 6)
  For i = 1 To UBound(arr, 1) - 1
    If Len(arr(i, 1)) > 0 And Len(arr(i, 2)) > 0 Then dic(0)(LCase(arr(i, 1))) = arr(i, 2) & "\"
    If Len(arr(i, 5)) > 0 And Len(arr(i, 6)) > 0 Then dic(1)(LCase(arr(i, 5))) = arr(i, 6)
  Next
  On Error GoTo errmsg
  For i = 1 To UBound(filename)
    t = Split(filename(i), "\"): f = t(UBound(t)): t = LCase(Split(f, "-")(0))
    If dic(0).exists(t) Then
      p = dic(0)(t): t = LCase(Left(f, 1))
      t = IIf(dic(1).exists(t), dic(1)(t), "其他") & "\"
      If Len(Dir(pth & t, vbDirectory)) = 0 Then MkDir pth & t
      p = pth & t & p
      If Len(Dir(p, vbDirectory)) = 0 Then MkDir p
      FileCopy filename(i), p & f
    Else
      MsgBox "无法定位药品名称" & vbNewLine & filename(i): Exit Sub
    End If
  Next
Exit Sub
errmsg:
  MsgBox filename(i) & vbNewLine & "无法写入文件，文件是否已经打开或磁盘已满？"
End Sub

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-19 08:04
'只是增加了一个选择源数据文件夹的弹出框，这个目标文件夹名称不一定是“分发库”

Option Explicit

谢谢你。我自己根据网上学到的，试着做一个文件重命名。但是遇到一些问题。
希望可以自动填充新文件名那一列，请老师帮我修改一下代码。
谢谢

EXCEL渣渣

EXCEL渣渣 发表于 2019-10-19 10:17
谢谢你。我自己根据网上学到的，试着做一个文件重命名。但是遇到一些问题。
希望可以自动填充新文件名那 ...

哈哈，摸索了下自己解决了

EXCEL渣渣

EXCEL渣渣 发表于 2019-10-19 10:17
谢谢你。我自己根据网上学到的，试着做一个文件重命名。但是遇到一些问题。
希望可以自动填充新文件名那 ...

老师你好，请问如何为文件名列下的文件名添加超级链接

一把小刀闯天下

'参考一下，，，

Option Explicit

Sub test()
  With ActiveSheet
    .Hyperlinks.Add .Range("a1"), "http://club.excelhome.net/thread-1503401-6-1.html"
  End With
End Sub

zpy2

EXCEL渣渣 发表于 2019-10-19 14:33
老师你好，请问如何为文件名列下的文件名添加超级链接

建议你还是建立一个简单规范化的数据结构来查，这样子达不到像百度一样的方便查询。

lovemh1987

根据楼上诸位大神的代码上 改了下。你看能否满足需要。

EXCEL渣渣

谢谢你，大神已经帮我完美解决了。

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-19 15:02
'参考一下，，，

Option Explicit

老师你好，不是这样啊。
应该是我通过代码，获得了我想要的文件的名称于文件列，并将我获得的文件加上相应超级链接，我只要点击那个文件名就可以打开那个文件了。附件我已经上传过了，请老师看看应该在我的代码里如何修改，谢谢。