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

johnchen55 · 发表于 2019-10-17 18:35

注释中都有说明, 有几个参数可以自行调整
1, 原Excel表格中做了一个名为code的工作表, 存放代码1,2
2, xlsm源文件放在与分发库同级目录下

Sub moveFile()
'思路分析
'原Excel表格中做了一个名为code的工作表, 存放代码1,2
'假设所有需要分发的文件都已存放在 .\分发库先手工保证文件名的有效性
'只需要取文件名的前5位作为药名, 文件名的后4位的第1位是部门代码
'根据情况来决定是否创建文件夹以及移动文件
Dim shtCode As Worksheet
Dim intRow1, intRow2, intIsMove As Integer
Dim i, j, k, m, n As Integer
Dim arrCode(), arrDept(), arrFile()
Dim strName, strDept, strDeptPref, strDesDir, strSrcDir, strFile, strSrc, strDes As String
Dim intName, intDept As Integer
strDesDir = ThisWorkbook.Path
strSrcDir = ThisWorkbook.Path & "\分发库"
intIsMove = 1 '1为移动, 0为复制
'将代码1和代码2装入字典
Set shtCode = Sheets("code")
With shtCode
intRow1 = Cells(.Cells.Rows.Count, 1).End(xlUp).Row
intRow2 = Cells(.Cells.Rows.Count, 3).End(xlUp).Row
arrCode = Range(.Cells(2, 1), .Cells(intRow1, 2))
arrDept = Range(.Cells(2, 3), .Cells(intRow2, 4))
Set dicCode = CreateObject("scripting.dictionary")
Set dicDept = CreateObject("scripting.dictionary")
For i = 1 To UBound(arrCode)
If Not dicCode.exists(arrCode(i, 1)) Then
dicCode(arrCode(i, 1)) = arrCode(i, 2)
Else
MsgBox "代码1名称有重复, 请检查后重试"
GoTo 100
End If
Next
For i = 1 To UBound(arrDept)
If Not dicDept.exists(arrCode(i, 1)) Then
dicDept(arrDept(i, 1)) = arrDept(i, 2)
Else
MsgBox "代码2名称有重复, 请检查后重试"
GoTo 100
End If
Next
End With
'获取分发库的文件名称
j = 0
strFile = Dir(strSrcDir & "\*.*")
Do While strFile <> ""
j = j + 1
ReDim Preserve arrFile(1 To j)
arrFile(j) = strFile
strFile = Dir
Loop
'分发文件
For k = 1 To UBound(arrFile)
'获取文件名称药名部门
strFile = Trim(arrFile(k))
m = InStr(1, strFile, ".")
If m > 0 Then
strFile = Trim(Left(strFile, m - 1))
End If
strName = dicCode(Left(strFile, 5))
strDept = dicDept(Left(Right(strFile, 4), 1))
If strName = "" Or strDept = "" Then
MsgBox "无法匹配的文件:" & arrFile(k)
GoTo 200
End If
'创建目录
If Dir(strDesDir & "" & strDept, vbDirectory) = "" Then
MkDir strDesDir & "" & strDept
End If
If Dir(strDesDir & "" & strDept & "" & strName, vbDirectory) = "" Then
MkDir strDesDir & "" & strDept & "" & strName
End If
'移动文件
strSrc = strSrcDir & "" & arrFile(k)
strDes = strDesDir & "" & strDept & "" & strName & ""
If Dir(strDes & "" & arrFile(k)) = "" Then
Set fso = CreateObject("scripting.filesystemobject")
If intIsMove = 1 Then
fso.moveFile strSrc, strDes
Else
fso.copyFile strSrc, strDes
End If
End If
200
Next
MsgBox "已完成全部文件分发"
100
End Sub

复制代码

一把小刀闯天下 · 发表于 2019-10-17 18:49

EXCEL渣渣发表于 2019-10-17 18:32
我想知道如何入门VBA?

先了解一下常见的变量类型，基本的就可以了。比如长、短整形，长、短浮点型，字符串型，当然不指定类型就是变体型啦。如果你有点基础这直接忽律

然后了解一下组成程序化语言最基本的流程，比如 if endif ，for next，do while loop，select case end select等。同样如果你有点基础这直接忽律

接下来就是解题思路啦，这需要实战。于是最重要的一步来啦：来这义务敲100段代码，，，

EXCEL渣渣 · 发表于 2019-10-17 19:24

一把小刀闯天下发表于 2019-10-17 18:49
先了解一下常见的变量类型，基本的就可以了。比如长、短整形，长、短浮点型，字符串型，当然不指定类型就 ...

有书，视频推荐吗？
你说的名词我都有听过，但是就是不会用

一把小刀闯天下 · 发表于 2019-10-17 19:35

EXCEL渣渣发表于 2019-10-17 19:24
有书，视频推荐吗？
你说的名词我都有听过，但是就是不会用

觉得你还是有点基础的。VBA的书我没有看过，网上下点基本的资料就可以啦，我并不清楚是不是有VBA视频的。

不同语言解决问题的思路都是相通的，而且VBA学起来应该是比较简单的吧。

于是从现在开始敲代码吧，当然还是100段，，，

EXCEL渣渣 · 发表于 2019-10-17 19:37

johnchen55 发表于 2019-10-17 18:35
注释中都有说明, 有几个参数可以自行调整
1, 原Excel表格中做了一个名为code的工作表, 存放代码1,2
2, xl ...

论坛还是有好多老师啊，谢谢你热心帮助，我的工作可以减轻不少了。

EXCEL渣渣 · 发表于 2019-10-17 19:41

一把小刀闯天下发表于 2019-10-17 19:35
觉得你还是有点基础的。VBA的书我没有看过，网上下点基本的资料就可以啦，我并不清楚是不是有VBA视频的。 ...

当程序员是我的梦想，但是却选择了药学，而我的妹妹却成一计算机博士，呵呵。天意弄人啊

一把小刀闯天下 · 发表于 2019-10-17 19:53

EXCEL渣渣发表于 2019-10-17 19:41
当程序员是我的梦想，但是却选择了药学，而我的妹妹却成一计算机博士，呵呵。天意弄人啊

基因放在这儿，稍微用点力就可以敲出很不错的VBA代码的。代码可以敲错，但这个药用错了那是无法重来的。

-----------------------
“代码”与“药品名称”对应关系是行业规定还是你们自己定的规则的，，，

EXCEL渣渣 · 发表于 2019-10-17 19:59

一把小刀闯天下发表于 2019-10-17 19:53
基因放在这儿，稍微用点力就可以敲出很不错的VBA代码的。代码可以敲错，但这个药用错了那是无法重来的。
...

内部规定的，好系统化管理。

一把小刀闯天下 · 发表于 2019-10-17 20:01

EXCEL渣渣发表于 2019-10-17 19:59
内部规定的，好系统化管理。

嗯，不具备通用性，只是了解一下而已，非常感谢。

EXCEL渣渣 · 发表于 2019-10-17 20:04

一把小刀闯天下发表于 2019-10-17 20:01
嗯，不具备通用性，只是了解一下而已，非常感谢。

放心，病人生命所托，岂敢儿戏。

		自动登录	找回密码
密码			免费注册

[求助] 如何利用VBA进行文件的分发

评分

最新热点 /1