没有合适的资源?快使用搜索试试~ 我知道了~
Sub F2无格式粘贴到新word并保存关闭() Sub F3无格式粘贴程序() Sub F4带图表粘贴到新word并保存关闭() Sub F5格式调整程序() Sub F6编号() Sub F7加答案() Sub F8批处理() Sub F8批处理_AllDir() Sub F8批处理_AllFile() Sub F8批处理_文档解密() Sub F8批处理_重命名() Sub F8批处理_word导出图片()
资源推荐
资源详情
资源评论
Public excelRows As Integer
Public reCount As Integer
Public myDoc As Object
Public wordApp As Object
Public excelApp As Object
Public mySheet As Object
Public xlBook As Object
Public isReAlign As Boolean
Public myRange As Range
Public myName As String
Public myPath As String
Public defaultPath As String
Public myCommand As String
Public myStr As String 'temporary string
Public myBool As Boolean 'temporary tpbool
Public myInt As Integer 'temporary Integer
Public myBit As Integer
Sub F 删除重复文件名()
If myPath = "" Then
Exit Sub
End If
If Dir(defaultPath + "\已上传[TXT]", vbDirectory) <> "" Then myPath = defaultPath + "\已
上传[TXT]"
If Dir(defaultPath + "\综合", vbDirectory) <> "" Then myPath = defaultPath + "\综合"
myInt = 1
Do While Worksheets("Sheet1").Range("C" + CStr(myInt)).Value <> ""
myName = myPath + "\" + Worksheets("Sheet1").Range("C" + CStr(myInt)).Value + ".txt"
'文件名
If Dir(myName) = "" Then '文件不存在
If Worksheets("Sheet1").Range("E" + CStr(myInt)).Value = "" Then '内容不存在,新建
Open myName For Output As #1
' Print #1, "这里写入文件内容"
Close #1
Worksheets("Sheet1").Rows(myInt).Delete
Else
myInt = myInt + 1
End If
Else
Worksheets("Sheet1").Rows(myInt).Delete
End If
Loop
MsgBox ("删去完毕")
End Sub
Sub F 删除重复记录()
Dim str1 As String, str2 As String, boo1 As Boolean, boo2 As Boolean
myInt = 1
reCount = 0
boo1 = True
boo2 = True
Do While Worksheets("Sheet1").Range("C" + CStr(myInt + 1)).Value <> ""
str1 = Worksheets("Sheet1").Range("C" + CStr(myInt)).Value '获取 资料名称
str2 = Worksheets("Sheet1").Range("C" + CStr(myInt + 1)).Value
If Replace(Replace(str1, Chr(-24159), ""), Chr(32), "") = Replace(Replace(str2, Chr(-24159),
""), Chr(32), "") Then
'修改 资料名称
If boo1 And InStr(Worksheets("Sheet1").Range("C" + CStr(myInt + 1)).Value, Chr(32)) >
0 Or InStr(Worksheets("Sheet1").Range("C" + CStr(myInt + 1)).Value, Chr(-24159)) > 0 Then
Worksheets("Sheet1").Range("C" + CStr(myInt)).Value =
Worksheets("Sheet1").Range("C" + CStr(myInt + 1)).Value
curInt = curInt + 1
boo1 = False
End If
'修改 资料分类
If boo2 And Worksheets("Sheet1").Range("B" + CStr(myInt + 1)).Value = "基础知识" Or
Worksheets("Sheet1").Range("B" + CStr(myInt + 1)).Value = "学术论文" Then
Worksheets("Sheet1").Range("B" + CStr(myInt)).Value =
Worksheets("Sheet1").Range("B" + CStr(myInt + 1)).Value
boo2 = False
End If
Worksheets("Sheet1").Rows(myInt + 1).Delete
reCount = reCount + 1
Else
myInt = myInt + 1
boo1 = True
boo2 = True
End If
Loop
MsgBox ("删去完毕!删去" + CStr(reCount) + "条。")
End Sub
Sub F 修改命名()
Dim pos As Integer
If myCommand = "" Then Exit Sub
reCount = 0
For myInt = 2 To excelRows
myStr = Worksheets("Sheet1").Range("C" + CStr(myInt)).Value
If myCommand = "修改命名_删除" Then
pos = 0
myStr = Replace(myStr, "09 城市规划师考试辅导", "")
myStr = Replace(myStr, "09 年注册城市规划师", "")
If pos = 0 And InStr(myStr, "_") > 0 Then
pos = InStr(myStr, "_")
If pos <> 0 Then myStr = Right(myStr, Len(myStr) - pos)
End If
If InStr(myStr, "09") > 0 Or InStr(myStr, "10") > 0 Or InStr(myStr, "00") > 0 Or
InStr(myStr, "年") > 0 Then
If pos = 0 And InStr(myStr, ":") > 0 Then
pos = InStr(myStr, ":")
If pos <> 0 Then myStr = Right(myStr, Len(myStr) - pos)
End If
If pos = 0 And InStr(myStr, "-") > 0 Then
pos = InStr(myStr, "-")
If pos <> 0 And Len(myStr) - pos > 5 Then myStr = Right(myStr, Len(myStr) - pos)
'放在后面,免得改变 pos 大小
End If
End If
If Left(myStr, 1) = ":" Or Left(myStr, 1) = "-" Or Left(myStr, 1) = "_" Then
myStr = Right(myStr, Len(myStr) - 1)
End If
myStr = Replace(myStr, "考点解析之", "")
If myStr <> Worksheets("Sheet1").Range("C" + CStr(myInt)).Value Then reCount =
reCount + 1
Worksheets("Sheet1").Range("C" + CStr(myInt)).Value = myStr
End If
If myCommand = "修改命名_添加" Then
' Worksheets("Sheet1").Range("B" + CStr(myInt)).Value =
Replace(Worksheets("Sheet1").Range("B" + CStr(myInt)).Value, "规划知识:", "")
' Worksheets("Sheet1").Range("B" + CStr(myInt)).Value =
Replace(Worksheets("Sheet1").Range("B" + CStr(myInt)).Value, "心得:", "")
If True And Len(myStr) <= 10 And InStr(Worksheets("Sheet1").Range("B" +
CStr(myInt)).Value, ":") = 0 Then
If Worksheets("Sheet1").Range("B" + CStr(myInt)).Value = "基础知识" Then
Worksheets("Sheet1").Range("C" + CStr(myInt)).Value = " 规 划 知 识 : " +
Worksheets("Sheet1").Range("C" + CStr(myInt)).Value
reCount = reCount + 1
End If
If Worksheets("Sheet1").Range("B" + CStr(myInt)).Value = "职场心得" Then
Worksheets("Sheet1").Range("C" + CStr(myInt)).Value = " 心 得 : " +
Worksheets("Sheet1").Range("C" + CStr(myInt)).Value
reCount = reCount + 1
End If
End If
End If
If myCommand = "加作者" Then
Worksheets("Sheet1").Range("E" + CStr(myInt)).Value =
RTrim(Worksheets("Sheet1").Range("E" + CStr(myInt)).Value)
If InStr(Worksheets("Sheet1").Range("E" + CStr(myInt)).Value, "作者:") = 0 Then
Do
myBit = Asc(Right(Worksheets("Sheet1").Range("E" + CStr(myInt)).Value, 1))
If myBit = -24159 Or myBit = 32 Or myBit = 13 Or myBit = 10 Then
Worksheets("Sheet1").Range("E" + CStr(myInt)).Value =
Left(Worksheets("Sheet1").Range("E" + CStr(myInt)).Value,
Len(Worksheets("Sheet1").Range("E" + CStr(myInt)).Value - 1))
Else
Exit Do
End If
Loop
Worksheets("Sheet1").Range("E" + CStr(myInt)).Value =
Worksheets("Sheet1").Range("E" + CStr(myInt)).Value + Chr(13) + "作者:不详"
End If
End If
Next myInt
If myCommand = "修改命名_添加" Then
MsgBox ("添加" + CStr(reCount) + "次!")
Else
MsgBox ("清除" + CStr(reCount) + "次!")
End If
End Sub
Sub F 常用语()
Worksheets("Sheet1").Range("A5").Value = 22
Range("A1:H8").Formula = "=Rand()"
Worksheets(1).Cells(1, 1).Value = 24
剩余10页未读,继续阅读
资源评论
xj06541
- 粉丝: 2
- 资源: 25
上传资源 快速赚钱
- 我的内容管理 展开
- 我的资源 快来上传第一个资源
- 我的收益 登录查看自己的收益
- 我的积分 登录查看自己的积分
- 我的C币 登录后查看C币余额
- 我的收藏
- 我的下载
- 下载帮助
安全验证
文档复制为VIP权益,开通VIP直接复制
信息提交成功