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

EXCEL渣渣

朱荣兴 发表于 2019-10-15 15:53
代码是猜着写的，仅供参考
在代码查询  文件中运行代码，
特别注意：把代码查询  文件放到跟部门A，部门B ...

您好，我刚刚测试过了，不行。谢谢你

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-15 15:36
看了一下里面没有pdf文件的，另外“代码查询“表格中数据太少。

如果当前文件找不到规则怎么处理（代码 ...

希望您可以帮一下我，谢谢

EXCEL渣渣

朱荣兴 发表于 2019-10-15 17:16
呵呵呵，我无语了，

我的思路是这样的：
需要分类的pdf文件，根据代码查询表（查询表我可以按需要扩大，vba按钮放在查询表里）进行查询，如何查不到则弹出提示，查询到的话就直接复制到相应的文件夹内。老师，不知道这样可以吗？
请老师指点，谢谢

wusihua

试试吧，根据版主的代码修改了一点

wusihua

wusihua 发表于 2019-10-15 19:23
试试吧，根据版主的代码修改了一点

怎么传不了附件

EXCEL渣渣

wusihua 发表于 2019-10-15 19:26
怎么传不了附件

哈哈，尴尬了

一把小刀闯天下

EXCEL渣渣 发表于 2019-10-15 19:28
哈哈，尴尬了

'代码放入"代码查询"文件中，文件放在"分发库"目录上一级。供参考，，，

Option Explicit

Sub test()
  Dim arr, pth, filename(), dic, i, t, p, f
  pth = ThisWorkbook.Path & "\"
  If Len(pth & "分发库") = 0 Then MsgBox "!": Exit Sub
  If Not getfilename(filename, pth & "分发库", ".pdf") Then MsgBox "!!": Exit Sub
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a2:d" & [b2].End(xlDown).Row)
  For i = 1 To UBound(arr, 1)
    dic(LCase(arr(i, 1))) = pth & arr(i, 4) & "\" & arr(i, 2) & "\"
    If Len(Dir(pth & arr(i, 4), vbDirectory)) = 0 Then MkDir (pth & arr(i, 4))
  Next
  For i = 1 To UBound(filename)
    t = Split(filename(i), "\")
    f = t(UBound(t))
    t = LCase(Split(f, "-")(0))
    If dic.exists(t) Then
      p = dic(t)
      If Len(Dir(p, vbDirectory)) = 0 Then MkDir p
      FileCopy filename(i), p & f
    Else
      MsgBox t: Exit Sub '无法定位
    End If
  Next
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

lkqsmxw

一把小刀闯天下 发表于 2019-10-15 20:28
'代码放入"代码查询"文件中，文件放在"分发库"目录上一级。供参考，，，

Option Explicit

在您的基础上，改一改。不要介意哟。

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-15 20:28
'代码放入"代码查询"文件中，文件放在"分发库"目录上一级。供参考，，，

Option Explicit

谢谢你，经过实测可以达到目的了。谢谢你