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

EXCEL渣渣

lkqsmxw 发表于 2019-10-16 08:13
在您的基础上，改一改。不要介意哟。

您好，可以把代码分享一下吗？您的附件无法下载。谢谢

EXCEL渣渣

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

Option Explicit

您好。经过2天的测试发现了以下的问题。
如C0001-A19A001.PDF 应该放在部门A文件夹下阿司匹林文件夹里，但是C0001-A19B001.PDF不应该存放于部门A文件夹下阿司匹林文件夹里，而是应该存放于部门B文件夹下阿司匹林文件夹里.还有其他PDF也遇到相同的情况。只识别了药品名称，没有识别到科室。
可以请你帮忙修改以下代码修复BUG吗？
再次感谢您的帮助。谢谢

一把小刀闯天下

EXCEL渣渣 发表于 2019-10-17 14:04
您好。经过2天的测试发现了以下的问题。
如C0001-A19A001.PDF 应该放在部门A文件夹下阿司匹林文件夹里， ...

可以上个附件，我是按规则来确定目标文件夹的，你的规则是否有问题？

另外错误处理我也没有加上去，比如目标文件存在且已打开再覆盖就会出错，，，

---------------------
没注意后面还有条件，等一下我好好看一下再给你修改，，，

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-17 15:18
可以上个附件，我是按规则来确定目标文件夹的，你的规则是否有问题？

另外错误处理我也没有加上去，比 ...

附件我重新上传了，并且我重新整理了思路，希望可以帮你更好理解我想要的结果。
谢谢您能再次帮我解决问题。谢谢

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-17 15:18
可以上个附件，我是按规则来确定目标文件夹的，你的规则是否有问题？

另外错误处理我也没有加上去，比 ...

代码查询中代码1 和代码2，不是一一对应的关系的 如C001-A19A001 是要分发到部门A,C001-A19B001 是要分发到部门B,部门A是不会出现C001-A19B001 的。

一把小刀闯天下

EXCEL渣渣 发表于 2019-10-17 15:34
代码查询中代码1 和代码2，不是一一对应的关系的 如C001-A19A001 是要分发到部门A,C001-A19B001 是要分发 ...

'我太粗心了，你那个规则文件没看

'加了错误处理。应该差不多，自己再好好测试一下，有问题可继续，，，

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))) = arr(i, 2) & "\"
  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.exists(t) Then
      p = dic(t)
      t = Mid(UCase(Split(f, "-")(1)), 4, 1)
      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 t: 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-17 15:42
'我太粗心了，你那个规则文件没看

'加了错误处理。应该差不多，自己再好好测试一下，有问题可 ...

谢谢你，可以。

EXCEL渣渣

一把小刀闯天下 发表于 2019-10-17 15:42
'我太粗心了，你那个规则文件没看

'加了错误处理。应该差不多，自己再好好测试一下，有问题可 ...

您好。很抱歉再次打扰您。如果再文件细分可以吗？
如A=甲类，B=乙类，C=丙类，Z=特殊，。。。。。（详细在命名规则，代码查询内）
文件C0001-A19A001 放在丙类文件加下阿司匹林的文件内
文件A0001-A19A001 放在甲类文件加下布洛芬的文件内
。。。。。。
其他文件如F0012-1910017,就放在名为“”其他”的文件夹内

再次深感抱歉。当我开心地将我分好的文件给老板看时老板又改需求了老板太难伺候了。我太苦逼了

一把小刀闯天下

EXCEL渣渣 发表于 2019-10-17 17:51
您好。很抱歉再次打扰您。如果再文件细分可以吗？
如A=甲类，B=乙类，C=丙类，Z=特殊，。。。。。（详细 ...

'26楼附件，，，

Option Explicit

Sub test4()
  Dim arr, pth, filename(), dic(1), 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
  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-17 18:27
'26楼附件，，，

Option Explicit

我想知道如何入门VBA?