一套4个表格文件，分为脚本.xlam文件，基础数据.xlsx，还有用来登记脚本挑选出数据的文件电话号码.xlsx和登记需提分.xlsx2个文件。【水平有限，欢迎提出改进意见】（vba脚本是受亲戚委托给单位制作的用来批量处理excel表格的，大概2017年。）
窗体代码：
Public 填充选项, 更正格式
Public 存款余额小项, 负债担保小项, 务工地点小项, 合作资金需求小项, 填电话号码小项, 四种信用判定小项, 评分小项, 登记需提分小项
'Private Sub CheckBox11_change()'调试的时候点击选项会出现到这里了。奇怪。
'CheckBox1.Enabled = False
'CheckBox1.Value = 1
'CheckBox2.Enabled = False
'CheckBox2.Value = 1
'CheckBox3.Enabled = False
'CheckBox3.Value = 1
'CheckBox4.Enabled = False
'CheckBox4.Value = 1
'CheckBox5.Enabled = False
'CheckBox5.Value = 0
'CheckBox6.Enabled = False
'CheckBox6.Value = 0
'CheckBox7.Enabled = False
'CheckBox5.Value = 0
'CheckBox8.Enabled = False
'CheckBox6.Value = 0
'End Sub
Private Sub CheckBox9_Change() '调试的时候点击选项会出现到这里了，继续调试到这个语句完，不会去继续调试了。但是程序还在运行中。那以后怎么调试啊？郁闷。
If CheckBox9.Value = True Then
CheckBox1.Enabled = True
'CheckBox1.Value = 1
CheckBox2.Enabled = True
'CheckBox2.Value = 1
CheckBox3.Enabled = True
'CheckBox3.Value = 1
CheckBox4.Enabled = True
'CheckBox4.Value = 1
CheckBox5.Enabled = True
'CheckBox5.Value = 0
CheckBox6.Enabled = True
'CheckBox6.Value = 0
'CheckBox7.Enabled = True
'CheckBox5.Value = 0
'CheckBox8.Enabled = True
'CheckBox6.Value = 0
CheckBox8.Enabled = True
'CheckBox6.Value = 0
CheckBox10.Enabled = True
'CheckBox6.Value = 0
Else
CheckBox1.Enabled = False
'CheckBox1.Value = 1
CheckBox2.Enabled = False
'CheckBox2.Value = 1
CheckBox3.Enabled = False
'CheckBox3.Value = 1
CheckBox4.Enabled = False
'CheckBox4.Value = 1
CheckBox5.Enabled = False
'CheckBox5.Value = 0
CheckBox6.Enabled = False
'CheckBox6.Value = 0
'CheckBox7.Enabled = False
'CheckBox5.Value = 0
'CheckBox8.Enabled = False
'CheckBox6.Value = 0
'CheckBox10.Enabled = False
'CheckBox6.Value = 0
End If
End Sub
Private Sub CommandButton1_Click()
填充选项 = CheckBox9.Value
更正格式 = CheckBox10.Value
存款余额小项 = CheckBox1.Value
负债担保小项 = CheckBox2.Value
务工地点小项 = CheckBox3.Value
合作资金需求小项 = CheckBox4.Value
填电话号码小项 = CheckBox5.Value
四种信用判定小项 = CheckBox6.Value
评分小项 = CheckBox7.Value
登记需提分小项 = CheckBox8.Value
Label1.Visible = True
'If 填充选项 = True Then '这里必须写true或者false，o和1不好使啦。赋值的时候可以，取值的时候就不行了。
Call 填充选项开始 '这是入口
'ElseIf 更正格式 = True Then
'Call 更正格式开始
'End If
Label1.Visible = False
End Sub
Private Sub CommandButton2_Click()
UserForm1.Hide
End Sub
Private Sub UserForm_Initialize()
'窗口初始化的其中控件属性好，还是属性自己设置好了好呢？感觉一样。initialize是什么时候的事件。是窗口第一次生成，还是show的时候呢？还是hide之后show的时候算么？
CheckBox1.Enabled = False
'CheckBox1.Value = 1
CheckBox2.Enabled = False
'CheckBox2.Value = 1
CheckBox3.Enabled = False
'CheckBox3.Value = 1
CheckBox4.Enabled = False
'CheckBox4.Value = 1
CheckBox5.Enabled = False
'CheckBox5.Value = 0
CheckBox6.Enabled = False
'CheckBox6.Value = 0
'CheckBox7.Enabled = False
'CheckBox5.Value = 0
'CheckBox8.Enabled = False
'CheckBox6.Value = 0
'CheckBox10.Enabled = False
'CheckBox6.Value = 0
End Sub
模块1：
'本模块以填充为主
Dim gg As String '定义fld,gg为变量
Public file, filename As Variant '本模块使用，如为pulic全程序使用窗体中的public在其他模块引用，格式为 窗体名.变量名。
Public wb As Workbook '在上面声明为public
Sub 填充选项开始()
'UserForm2.Show'不能在这里添加，因为窗口出来了，不会掉，只能按个按钮加上代码才行唉。
Dim shell As Variant
Set shell = CreateObject("Shell.Application")
Set filePath = shell.BrowseForFolder(&O0, "选择文件夹", &H1 + &H10, "") '获取文件夹路径地址
Set shell = Nothing
If filePath Is Nothing Then '检测是否获得有效路径，如取消直接跳出程序
Exit Sub
Else
gg = filePath.Items.Item.Path
End If
Call 填充选项FileSearch(gg, "*.xls?")
End Sub
Sub 填充选项FileSearch(Path As String, Target As String)
Dim FSO As Object, Folder As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Folder In FSO.GetFolder(Path).SubFolders
Call 填充选项FileSearch(Folder.Path, Target)
Next Folder
For Each file In FSO.GetFolder(Path).Files
filename = Right(file, Len(file) - Len(Path) - 1)
If (filename Like Target Or filename Like "*.xls") And Left(filename, 2) <> "~$" Then
Call 填充选项打开文件
End If
Next file
End Sub
Public Sub 填充选项打开文件()
'Dim wb As Workbook '在上面声明为public
Set wb = Application.Workbooks.Open(file)
If wb Is Nothing Then MsgBox ("文件打开失败，请检查" & pth & fn & "是否存在！"): Exit Sub
Call 填充选项 '在此添加操作代码
'wb.Close True '如果无需保存，本参数用false
'wb.Close True
Workbooks(filename).Close True '因为经过后面一系列的过程，现在的filename来关闭文件。而不是用wb了。因为wb可能已经没有了（在更正格式那里，wb.close了。是不是这个变量也没有了，就像kill file一样。）。
End Sub
Sub 填充选项()
With Sheets("农户信息经济档案-表4")
'====下面部分为修改表4的家庭资产部分====
If UserForm1.存款余额小项 = True Then
.[C36] = a '没有赋值的a和b，单元格就是初始空格。避免单元格格式为0或""问题。
.[H36] = B
End If
'====下面部分为修改表4的借款担保部分====
If UserForm1.负债担保小项 = True Then
If .[B38] = 0 Or .[B38] = "" Then
.[B38] = 0
End If
If .[D38] = 0 Or .[D38] = "" Then
.[D38] = 0
End If
.[F38] = 0 '他行借款等开始
.[H38] = 0
.[J38] = 0
.[L38] = 0
End If
'====下面部分为修改表4的务工地点“宝鸡市”部分====
If UserForm1.务工地点小项 = True Then ' value只能是true或者false
.[F52] = "A-农、林、牧、渔业"
.[G52] = "610000陕西省"
.[H52] = "610300宝鸡市"
End If
'====下面部分为修改表4的我行合作及资金需求部分====
If UserForm1.合作资金需求小项 = True Then
.CheckBoxes("Check Box 64").Value = xlOn '合作选其他
.[D61] = "无" '需求选无000
.[G61] = 0
.[I61] = 0
End If
If UserForm1.填电话号码小项 = True Then
Dim i As Integer
For i = 1 To Workbooks.Count
If Workbooks(i).Name = "电话号码.xlsx" Then
h1 = 1
Exit For
End If
Next
If h1 = 0 Then '因为h1 不被赋值的话，那么就是空值，逻辑上等于0
Dim wb2 As Workbook
Dim file2
file2 = ThisWorkbook.Path & "/电话号码.xlsx"
Set wb2 = Application.Workbooks.Open(file2)
If wb2 Is Nothing Then MsgBox ("文件打开失败，请检查" & pth & fn & "是否存在！"): Exit Sub
End If
Dim 电话号码, 身份证号, 所在行号
身份证号 = .[B6]
If .[B5] = Application.WorksheetFunction.VLookup(身份证号, Workbooks("电话号码.xlsx").Worksheets("电话号码").Range("$A:$C"), 2, False) Then '.[B5]是姓名。
电话号码 = Application.WorksheetFunction.VLookup(身份证号, Workbooks("电话号码.xlsx").Worksheets("电话号码").Range("$A:$C"), 3, False)
.[I5] = 电话号码
Else
所在行号 = Application.WorksheetFunction.Match(身份证号, Workbooks("电话号码.xlsx").Worksheets("电话号码").Range("$A:$A"), 0)
Workbooks("电话号码.xlsx").Worksheets("电话号码").Range("D" & 所在行号) = filename
Workbooks("电话号码.xlsx").Worksheets("电话号码").Hyperlinks.Add Anchor:=Workbooks("电话号码.xlsx").Worksheets("电话号码").Range("D" & 所在行号), Address:=file
End If
End If
If UserForm1.四种信用判定小项 = True Then
Dim 本行借款, 本行担保, 不良借款余额, 不良担保余额
本行借款 = .[B38]
本行担保 = .[D38]
不良借款余额 = .[J39]
不良担保余额 = .[L39]
'初始选定为"2-否"，避免出现多个"1-是"
.[B12] = "2-否"
.[E12] = "2-否"
.[G12] = "2-否"
.[J12] = "2-否"
If (本行借款 > 0 Or 本行担保 > 0) And (不良余额 = 0 And 不良担保 = 0) Then
.[B12] = "1-是"
ElseIf 本行借款 + 本行担保 + 不良借款余额 + 不良担保余额 = 0 Then
.[E12] = "1-是"
' ElseIf 之前有过不良借款和不良担保的数据或表述(现在没有所以忽略这种情况) And (不良借款余额 + 不良担保余额 = 0) Then
' .[G12] = "1-是"
ElseIf 不良借款余额 > 0 Or 不良担保余额 > 0 Then
.[J12] = "1-是"
End If
End If
End With ' 评分里面的表4的，
If UserForm1.更正格式 = True Then
Call 更正格式打开文件
End If
If UserForm1.评分小项 = True Then
Call 表2评分
End If
If UserForm1.登记需提分小项 = True Then
Call 登记需提分小项
End If
End Sub
模块2：
'Dim gg As String '定义fld,gg为变量'为了后续功能工作，合并到一起了呢。不在本模块里面声明了。模块1里面变成public变量了。
'Dim file, filename As Variant'为了后续功能工作，合并到一起了呢。不在本模块里面声明了。
'Dim wb As Workbook ''为了后续功能工作，合并到一起了呢。不在本模块里面关闭了。
Public hsave '如果hsave有值了，说明经过了这个更正格式的过程，那么xls一定是xlsx了。后面再用到激活工作簿的时候，好引用正确的名字。
Sub 更正格式开始()
Application.DisplayAlerts = False
Call 更正格式选取文件夹
End Sub
Sub 更正格式选取文件夹()
Dim shell As Variant
Set shell = CreateObject("Shell.Application")
Set filePath = shell.BrowseForFolder(&O0, "选择文件夹", &H1 + &H10, "") '获取文件夹路径地址
Set shell = Nothing
If filePath Is Nothing Then '检测是否获得有效路径，如取消直接跳出程序
Exit Sub
Else
gg = filePath.Items.Item.Path
End If
Call 更正格式FileSearch(gg, "*.xlsx")
End Sub
Public Sub 更正格式FileSearch(Path As String, Target As String)
Dim FSO As Object, Folder As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Folder In FSO.GetFolder(Path).SubFolders
Call 更正格式FileSearch(Folder.Path, Target)
Next Folder
For Each file In FSO.GetFolder(Path).Files
' Dim filename '已经在声明区公开变量了。
filename = Right(file, Len(file) - Len(Path) - 1)
If (filename Like Target Or filename Like "*.xls") And Left(filename, 2) <> "~$" Then
Call 更正格式打开文件
End If
Next file
End Sub
Public Sub 更正格式打开文件()
'Dim wb As Workbook '放到声明区了，公共变量。
'Set wb = Application.Workbooks.Open(file)
'If wb Is Nothing Then MsgBox ("文件打开失败，请检查" & pth & fn & "是否存在！"): Exit Sub
'打开基础模版
Dim wb2 As Workbook
Set wb2 = Application.Workbooks.Open(ThisWorkbook.Path & "\" & "基础模版.xlsx")
If wb2 Is Nothing Then MsgBox ("文件打开失败，请检查" & pth & fn & "是否存在！"): Exit Sub
Call 更正格式提取数据 '在此添加操作代码
'wb.Close True '如果无需保存，本参数用false '移动到了最下面保存之后了。因为下面call嵌套太多，不停返回的话时间长。
End Sub
'Sub 复制基础模版表到用户信息簿()
' Windows("修正错误格式0619.xlsm").Activate '因为基础模版放到了带宏的工作簿里面，所以，可以用thisworkbook.activate.如下：
' ThisWorkbook.Activate
' Sheets("基础模版").Select '提示下标越界，可能加载宏格式的不适合select和activate方法吧。但是第二天测试，又可以了。
'Application.CutCopyMode = False
' ThisWorkbook.Sheets("基础模版").Copy Before:=Workbooks(filename).Sheets("农户信息经济档案-表4")
' Windows(filename).Activate
' Call 提取数据
'End Sub
Sub 更正格式提取数据()
Workbooks(filename).Activate '不知道哪一个工作表在激活状态。因为前面已经打开一个"基础模板.xlsx"，处于激活状态。
Dim 年龄, 健康状况, 文化程度, 经营年限, 新型农业经营主体, 住房性质, 婚姻状况, 家庭劳力, 遵纪守法, 家庭和睦, 涉诉被法院执行情况, 民间债务及民间不良信誉, 个人银行信用记录, 家庭年净收入, 家庭净资产, 资产负债率, 支出收入比率, 家庭资产可变现金额
With Sheets("农户信息经济档案-表4")
年龄 = .[G5]
健康状况 = .[I13]
文化程度 = .[B7]
经营年限 = .[J7]
新型农业经营主体 = .[B8]
住房性质 = .[I14]
婚姻状况 = .[I6]
家庭劳力 = .[G6]
遵纪守法 = .[E10]
家庭和睦 = .[B10]
涉诉被法院执行情况 = .[I10]
民间债务及民间不良信誉 = .[G10]
' 个人银行信用记录 =
有借款且有担保无不良信用记录 = .[B12]
无借款及担保记录且无不良信用记录 = .[E12]
曾有不良借款及担保但已清偿 = .[G12]
仍有不良借款或不良信用记录 = .[J12]
家庭年净收入 = .[J57]
家庭净资产 = .[F39]
资产负债率 = .[H39]
支出收入比率 = .[L57]
家庭资产可变现金额 = .[K36]
Dim 建档单位, 村组编码, 姓名, 性别, 移动电话, 身份证号, 家庭人口, 从事行业或工作单位, 居住地址, 户籍地址, 是否贫苦户, 本行借款, 本行担保, 不良借款余额, 不良贷款余额, 他行借款, 他行担保, 社会借款, 其他负债, 家庭经营性支出, 生活支出, 其他支出
'一、户主基本情况
建档单位 = .[B3]
村组编码 = .[H3]
姓名 = .[B5]
性别 = .[E5]
移动电话 = .[I5]
身份证号 = .[B6]
家庭人口 = .[E6]
从事行业或工作单位 = .[H7]
居住地址 = .[E13]
户籍地址 = .[E14]
是否贫苦户 = .[L13]
'三、家庭负债及对外担保情况
本行借款 = .[B38]
本行担保 = .[D38]
不良借款余额 = .[J39]
不良贷款余额 = .[L39]
他行借款 = .[F38]
他行担保 = .[H38]
社会借款 = .[J38]
其他负债 = .[L38]
'四、主要经营及收支情况
家庭经营性支出 = .[B57]
生活支出 = .[D57]
其他支出 = .[F57]
Dim 粮食, 棉花, 油料, 苹果, 油桃, 杏, 樱桃, 西瓜, 葡萄, 猕猴桃, 枣, 石榴, 梨, 药材, 花卉, 茶叶, 烤烟, 蔬菜, 食用菌, 苗木, 种植业其他
Dim 猪, 羊, 牛, 鸡, 鸭, 鹅, 鱼, 兔, 蚕桑, 养殖业其他
Dim 粮棉油加工, 茶叶加工, 食品加工, 药材加工, 农产品加工, 加工业其他
Dim 化肥, 农药, 种子, 农机具, 农业服务业其他
Dim 批发零售, 餐饮, 运输, 医药和医疗, 农副产品收购, 商业服务业其他
Dim 长期雇用, 临时打工
Dim 工资收入, 经营收入, 劳务收入, 其他收入 '家庭其他成员收入
'种植业
粮食 = .[Q40]
棉花 = .[R40]
油料 = .[S40]
苹果 = .[T40]
油桃 = .[U40]
杏 = .[V40]
樱桃 = .[W40]
西瓜 = .[S40]
葡萄 = .[Y40]
猕猴桃 = .[Z40]
枣 = .[AB40]
石榴 = .[AA40]
梨 = .[AC40]
药材 = .[AD40]
花卉 = .[AE40]
茶叶 = .[AF40]
烤烟 = .[AG40]
蔬菜 = .[AH40]
食用菌 = .[AI40]
苗木 = .[AJ40]
种植业其他 = .[AK40]
'养殖业=.
猪 = .[Q41]
羊 = .[R41]
牛 = .[S41]
鸡 = .[T41]
鸭 = .[U41]
鹅 = .[V41]
鱼 = .[W41]
兔 = .[X41]
蚕桑 = .[Y41]
养殖业其他 = .[Z41]
'加工业=.
粮棉油加工 = .[Q42]
茶叶加工 = .[R42]
食品加工 = .[S42]
药材加工 = .[T42]
农产品加工 = .[U42]
加工业其他 = .[V42]
'农业服务业=.
化肥 = .[Q43]
农药 = .[R43]
种子 = .[S43]
农机具 = .[T43]
农业服务业其他 = .[U43]
'商业服务业=.
批发零售 = .[Q44]
餐饮 = .[R44]
运输 = .[S44]
医药和医疗 = .[T44]
农副产品收购 = .[U44]
商业服务业其他 = .[V44]
'劳务业
长期雇用 = .[Q45]
临时打工 = .[R45]
'家庭其他成员收入=.
工资收入 = .[Q46]
经营收入 = .[R46]
劳务收入 = .[S46]
其他收入 = .[T46]
富秦卡 = .[Q47]
钻石卡 = .[R47]
金卡 = .[S47]
网银及手机银行 = .[T47]
资金需求其他 = .[U47]
资金需求无 = .[V47]
Dim 建档人, 复核人, 建档日期
建档人 = .[B62]
复核人 = .[F62]
建档日期 = .[J62]
End With
Workbooks("基础模版.xlsx").Activate
With Sheets("农户信息经济档案-表4")
.[G5] = 年龄
.[I13] = 健康状况
.[B7] = 文化程度
.[J7] = 经营年限
.[B8] = 新型农业经营主体
.[I14] = 住房性质
.[I6] = 婚姻状况
.[G6] = 家庭劳力
.[E10] = 遵纪守法
.[B10] = 家庭和睦
.[I10] = 涉诉被法院执行情况
.[G10] = 民间债务及民间不良信誉
'=个人银行信用记录
.[B12] = 有借款且有担保无不良信用记录
.[E12] = 无借款及担保记录且无不良信用记录
.[G12] = 曾有不良借款及担保但已清偿
.[J12] = 仍有不良借款或不良信用记录
'户主基本信息（2）
.[B3] = 建档单位
.[H3] = 村组编码
.[B5] = 姓名
.[E5] = 性别
.[I5] = 移动电话
.[B6] = 身份证号
.[E6] = 家庭人口
.[H7] = 从事行业或工作单位
.[E13] = 居住地址
.[E14] = 户籍地址
.[L13] = 是否贫苦户
.[B38] = 本行借款
.[D38] = 本行担保
.[J39] = 不良借款余额
.[L39] = 不良贷款余额
.[F38] = 他行借款
.[H38] = 他行担保
.[J38] = 社会借款
.[L38] = 其他负债
.[B57] = 家庭经营性支出
.[D57] = 生活支出
.[F57] = 其他支出
'家庭经营部分
.[Q40] = 粮食
.[R40] = 棉花
.[S40] = 油料
.[T40] = 苹果
.[U40] = 油桃
.[V40] = 杏
.[W40] = 樱桃
.[S40] = 西瓜
.[Y40] = 葡萄
.[Z40] = 猕猴桃
.[AB40] = 枣
.[AA40] = 石榴
.[AC40] = 梨
.[AD40] = 药材
.[AE40] = 花卉
.[AF40] = 茶叶
.[AG40] = 烤烟
.[AH40] = 蔬菜
.[AI40] = 食用菌
.[AJ40] = 苗木
.[AK40] = 种植业其他
'.='养殖业
.[Q41] = 猪
.[R41] = 羊
.[S41] = 牛
.[T41] = 鸡
.[U41] = 鸭
.[V41] = 鹅
.[W41] = 鱼
.[X41] = 兔
.[Y41] = 蚕桑
.[Z41] = 养殖业其他
'.='加工业
.[Q42] = 粮棉油加工
.[R42] = 茶叶加工
.[S42] = 食品加工
.[T42] = 药材加工
.[U42] = 农产品加工
.[V42] = 加工业其他
'.='农业服务业
.[Q43] = 化肥
.[R43] = 农药
.[S43] = 种子
.[T43] = 农机具
.[U43] = 农业服务业其他
'.='商业服务业
.[Q44] = 批发零售
.[R44] = 餐饮
.[S44] = 运输
.[T44] = 医药和医疗
.[U44] = 农副产品收购
.[V44] = 商业服务业其他
'.='劳务业
.[Q45] = 长期雇用
.[R45] = 临时打工
'.='家庭其他成员收入
.[Q46] = 工资收入
.[R46] = 经营收入
.[S46] = 劳务收入
.[T46] = 其他收入
.[Q47] = 富秦卡
.[R47] = 钻石卡
.[S47] = 金卡
.[T47] = 网银及手机银行
.[U47] = 资金需求其他
.[V47] = 资金需求无
.[B62] = 建档人
.[F62] = 复核人
.[J62] = 建档日期
End With
Call 更正格式复制单元格
End Sub
Sub 更正格式复制单元格()
' 复制单元格 Macro
'
'
' '====下面复制照片=======好像不能用pastespecial那样的语句，可能是照片对象在。提示，不能对合并单元格做部分更改。
'Sheets("农户信息经济档案-表4").Activate
'Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K4:L10").Select 'windows(filename).sheets好像没有这个对象sheets，所以换了workbooks对象，窗口不用来回切换。
' Selection.Copy
'Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K4").PasteSpecial (xlPasteAll)
' Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K4").Select
'Selection.Paste
' Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K4:L10").Select
'ActiveSheet.Paste
' Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K4:L10").Select
'ActiveSheet.Paste
Workbooks(filename).Sheets("农户信息经济档案-表4").Activate
Range("K4:L10").Select 'windows(filename).sheets好像没有这个对象sheets，所以换了workbooks对象，窗口不用来回切换。
Selection.Copy
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Activate
Range("K4:L10").Select
ActiveSheet.Paste
Application.CutCopyMode = False '发现图片复制了两张，有一张是之前的做实验的文件里面的加这句，试试。发现原因不是这个。
'Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K4:L10").Copy '这两句提取不到照片。估计不能用编程的方式只能提取单元格的值（编程应该是shapes对象），只能是模拟的方式。
'Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K4:L10").PasteSpecial (xlPasteValuesAndNumberFormats)
'========下面复制单元格区域=====
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A16:L25").Copy
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A16:L25").PasteSpecial (xlPasteValuesAndNumberFormats)
'这个如果是 xlpastevalue，就会提醒单元格大小相同。调试时改成xlPasteValuesAndNumberFormats，还是提醒，重新运行就好了。模拟写法的语句，也是会遇到这个重新运行就好了。
'有时间，好好比较下那个粘贴选项的效果，怎么纯数值的时候总是提醒呢？
'------------------------下面是模拟写法，从录制宏得到-------------------------------------
'Workbooks(filename).Sheets("农户信息经济档案-表4").Activate '家庭成员
'Range("A16:L25").Select 'windows(filename).sheets好像没有这个对象sheets，所以换了workbooks对象，窗口不用来回切换。
'Selection.Copy
'Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Activate
'Range("A16").Select
'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Application.CutCopyMode = False
'------------------------上面是模拟写法，从录制宏得到-------------------------------------
'Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A28:L34").Copy '家庭资产部分
'Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A28:L34").PasteSpecial (xlPasteValuesAndNumberFormats)
'==================家庭资产新方式-避免保留无格式及调整项目顺序==========================
Dim i
For i = 28 To 34
If Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i) = "01-房产" Then
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i & ":" & "G" & i).Copy '家庭资产部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A28:G28").PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("H28") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("H" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("J28") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("J" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K28") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K" & i)
ElseIf Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i) = "02-交通工具" Then
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i & ":" & "G" & i).Copy '家庭资产部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A29:G29").PasteSpecial (xlPasteValuesAndNumberFormats) '这个语句是不是不能只指定第一个单元格粘贴呢？还是跟后面的粘贴格式有关。
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("H29") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("H" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("J29") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("J" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K29") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K" & i)
ElseIf Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i) = "03-大型农机具" Then
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i & ":" & "G" & i).Copy '家庭资产部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A30:G30").PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("H30") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("H" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("J30") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("J" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K30") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K" & i)
ElseIf Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i) = "04-牲畜" Then
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i & ":" & "G" & i).Copy '家庭资产部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A31:G31").PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("H28") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("H" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("J28") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("J" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K28") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K" & i)
ElseIf Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i) = "05-土地" Then
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i & ":" & "G" & i).Copy '家庭资产部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A32:G32").PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("H32") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("H" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("J32") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("J" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K32") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K" & i)
ElseIf Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i) = "06-林权" Then
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i & ":" & "G" & i).Copy '家庭资产部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A33:G33").PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("H33") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("H" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("J33") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("J" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K33") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K" & i)
ElseIf Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i) = "07-其他资产" Then
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("A" & i & ":" & "G" & i).Copy '家庭资产部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("A34:G34").PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("H34") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("H" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("J34") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("J" & i)
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("K34") = Workbooks(filename).Sheets("农户信息经济档案-表4").Range("K" & i)
End If
Next
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("I42:L53").Copy '经营右边部分
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("I42:L53").PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks(filename).Sheets("农户信息经济档案-表4").Range("C54:L55").Copy '经营最后一行
Workbooks("基础模版.xlsx").Sheets("农户信息经济档案-表4").Range("C54:L55").PasteSpecial (xlPasteValuesAndNumberFormats)
Call 更正格式保存修改后的用户工作簿
End Sub
Sub 更正格式保存修改后的用户工作簿()
wb.Close True '先关掉原文件，再保存，不然提示不能保存为已经打开的文件。如果从 xls到xlsx的话，就不用了。下面也不用kill了。
filenew = file 'kill了，就得先留下。不知道kill文件，为什么还有这个功能。
Kill file
If filename Like "*.xls" Then
filenew = filenew & "x"
'MsgBox file '这里的话已经是找不到文件了。提示为什么说是文件呢？
file = filenew '这里居然还可以赋值。而且因为声明的时候是public，所以评分在模块4里面也快成用到。就是登记需提分那里加链接的地方，用到file。
'MsgBox file
filename = filename & "x" '前面经过了更正格式过程的话，就有值了。那么如果是xls的格式，就需要在文件名上加x才是现在的文件名。这里要把最新的file赋值，以后好用。
End If
'ActiveWorkbook.SaveAs filename:=filenew & "x", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'Else
Workbooks("基础模版.xlsx").SaveAs filename:=filenew, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'End If
'ActiveWorkbook.Close True '为了后续功能工作，合并到一起了呢。
hsave = 1 '如果hsave有值了，说明经过了这个更正格式的过程，那么xls一定是xlsx了。后面再用到激活工作簿的时候，好引用正确的名字。
End Sub
模块3：
Sub 快捷方式启动()
Unload UserForm1 '不加这句，窗口.hide只是隐藏了。复选框的勾还在。隐藏了，就可以去打开其他的工作表了。
UserForm1.Show
End Sub
Sub 填手机号开始()
End Sub
Sub 记录需要另外加分的()
If 18 <= Sheets("农户信息经济档案-表4").[G5] <= 60 And Sheets("农户信用等级评估-表2").[F27] < 60 Then
Workbooks("需要加分农户记录.xlsx").Worksheets(1).[A1] = Active.Workbooks.Path
End If
End Sub
Sub 开始()
UserForm1.Show
Dim shell As Variant
Set shell = CreateObject("Shell.Application")
Set filePath = shell.BrowseForFolder(&O0, "选择文件夹", &H1 + &H10, "") '获取文件夹路径地址
Set shell = Nothing
If filePath Is Nothing Then '检测是否获得有效路径，如取消直接跳出程序
Exit Sub
Else
gg = filePath.Items.Item.Path
End If
Call FileSearch(gg, "*.xls?")
End Sub
Sub FileSearch(Path As String, Target As String)
Dim FSO As Object, Folder As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Folder In FSO.GetFolder(Path).SubFolders
Call FileSearch(Folder.Path, Target)
Next Folder
For Each file In FSO.GetFolder(Path).Files
Dim filename
filename = Right(file, Len(file) - Len(Path) - 1)
If filename Like Target And Left(filename, 2) <> "~$" Then
Call 打开文件
End If
Next file
End Sub
Public Sub 打开文件()
Dim wb As Workbook
Set wb = Application.Workbooks.Open(file)
If wb Is Nothing Then MsgBox ("文件打开失败，请检查" & pth & fn & "是否存在！"): Exit Sub
Call 评分 '在此添加操作代码
wb.Close True '如果无需保存，本参数用false
End Sub
模块4：
Sub 表2评分()
'=============下面部分是表2评分============
Workbooks(filename).Activate '不知道哪一个工作表在激活状态。因为复选框选中哪些服务不知道。
With Sheets("农户信息经济档案-表4")
If UserForm1.评分小项 = True Then
Dim 年龄, 健康状况, 文化程度, 经营年限, 新型农业经营主体, 住房性质, 婚姻状况, 家庭劳力, 遵纪守法, 家庭和睦, 涉诉被法院执行情况, 民间债务及民间不良信誉, 个人银行信用记录, 家庭年净收入, 家庭净资产, 资产负债率, 支出收入比率, 家庭资产可变现金额
年龄 = .[G5]
健康状况 = .[I13]
文化程度 = .[B7]
经营年限 = .[J7]
新型农业经营主体 = .[B8]
住房性质 = .[I14]
婚姻状况 = .[I6]
家庭劳力 = .[G6]
遵纪守法 = .[E10]
家庭和睦 = .[B10]
涉诉被法院执行情况 = .[I10]
民间债务及民间不良信誉 = .[G10]
' 个人银行信用记录 =
有借款且有担保无不良信用记录 = .[B12]
无借款及担保记录且无不良信用记录 = .[E12]
曾有不良借款及担保但已清偿 = .[G12]
仍有不良借款或不良信用记录 = .[J12]
家庭年净收入 = .[J57]
家庭净资产 = .[F39]
资产负债率 = .[H39]
支出收入比率 = .[L57]
家庭资产可变现金额 = .[K36]
With Sheets("农户信用等级评估-表2")
Dim 年龄得分, 健康状况得分, 文化程度得分, 经营年限得分, 新型农业经营主体得分, 住房性质得分, 婚姻状况得分, 家庭劳力得分, 遵纪守法得分, 家庭和睦得分, 涉诉被法院执行情况得分, 民间债务及民间不良信誉得分, 个人银行信用记录得分, 家庭年净收入得分, 家庭净资产得分, 资产负债率得分, 支出收入比率得分, 家庭资产可变现金额得分
Select Case 年龄
Case 30 To 44
年龄得分 = 3
Case 45 To 54, 22 To 29
年龄得分 = 2
Case 18 To 21, 55 To 64
年龄得分 = 1
Case Else
年龄得分 = 0
End Select
Select Case 健康状况
Case Is = "01-健康"
健康状况得分 = 4
Case Is = "02-一般"
健康状况得分 = 2
Case Is = "03-较差"
健康状况得分 = 1
End Select
Select Case 文化程度
Case Is = "01-大专及以上"
文化程度得分 = 3
Case Is = "02-中专", Is = "03-高中"
文化程度得分 = 2
Case Else
文化程度得分 = 1
End Select
Select Case 经营年限
Case Is >= 5
经营年限得分 = 3
Case 3 To 4.5
经营年限得分 = 2
Case Is < 3
经营年限得分 = 1
End Select
Select Case 新型农业经营主体
Case Is = "09-无"
新型农业经营主体得分 = 0
Case Else
新型农业经营主体得分 = 3
End Select
Select Case 住房性质
Case Is = "01-自建", Is = "02-自购"
住房性质得分 = 2
Case Is = "03-按揭"
住房性质得分 = 1
Case Is = "04-租赁"
住房性质得分 = 0
Case Is = "05-其他"
住房性质得分 = 0
End Select
Select Case 婚姻状况
Case Is = "00-未婚"
婚姻状况得分 = 2
Case Is = "01-已婚"
婚姻状况得分 = 3
Case Is = "02-丧偶", Is = "03-离异"
婚姻状况得分 = 1
End Select
Select Case 家庭劳力
Case Is >= 2
家庭劳力得分 = 2
Case Is = 1
家庭劳力得分 = 1
End Select
Select Case 遵纪守法
Case Is = "0-无"
遵纪守法得分 = 3
Case Is = "1-有"
遵纪守法得分 = 0
End Select
Select Case 家庭和睦
Case Is = "01-和睦"
家庭和睦得分 = 3
Case Is = "02-一般"
家庭和睦得分 = 2
Case Is = "03-不和睦"
家庭和睦得分 = 0
End Select
Select Case 涉诉被法院执行情况
Case Is = "0-无"
涉诉被法院执行情况得分 = 2
Case Is = "1-有"
涉诉被法院执行情况得分 = 0
End Select
Select Case 民间债务及民间不良信誉
Case Is = "0-无"
民间债务及民间不良信誉得分 = 2
Case Is = "1-有"
民间债务及民间不良信誉得分 = 0
End Select
If 有借款且有担保无不良信用记录 = "1-是" Then
个人银行信用记录得分 = 10
ElseIf 无借款及担保记录且无不良信用记录 = "1-是" Then
个人银行信用记录得分 = 8
ElseIf 曾有不良借款及担保但已清偿 = "1-是" Then
个人银行信用记录得分 = 5
ElseIf 仍有不良借款或不良信用记录 = "1-是" Then
个人银行信用记录得分 = 0
Else
MsgBox "个人银行信用记录未正确选择"
Stop
End If
Select Case 家庭年净收入
Case Is >= 80000
家庭年净收入得分 = 20
Case Else
家庭年净收入得分 = 20 - (Fix((80000 - 家庭年净收入) / 10000) + 1) * 2.5 'fix只取整数位（不是四舍五入）4.5只取4
End Select '这里的情况和下面类似，但是不会出现小于0的情况。fix(家庭年净收入/10000)*2.5
Select Case 家庭净资产
Case Is >= 200000
家庭净资产得分 = 20
Case Is <= 0 '这样的地方，怎么能够知道哪些区间呢？什么是最直接的关系呢？而不是用这种算式的呢？
家庭净资产得分 = 0
Case Else
家庭净资产得分 = 20 - (Fix((200000 - 家庭净资产) / 10000) + 1) * 1 'fix只取整数位（不是四舍五入）4.5只取4
End Select '20-(20-fix(家庭净资产/10000)) 也就是fix(家庭净资产/10000) '这种算法是最好的。0的情况也能包含在内。
'Select Case 资产负债率
'Case Is >= 0.7
'资产负债率得分 = 0
'Case 0.1 To 0.6999999
'资产负债率得分 = (Fix((0.7 - 资产负债率) / 0.1) + 1) * 1 'fix只取整数位（不是四舍五入）4.5只取4
'Case Is < 0.1
'资产负债率得分 = 6
'End Select
If 资产负债率 >= 0.7 Then
资产负债率得分 = 0
ElseIf 资产负债率 >= 0.1 And 资产负债率 < 0.7 Then
资产负债率得分 = (Fix((0.7 - 资产负债率) / 0.1) + 1) * 1 'fix只取整数位（不是四舍五入）4.5只取4
ElseIf 资产负债率 < 0.1 Then
资产负债率得分 = 6 '原来上一条判断会导致小于0.1的情况得7分。
End If
'Select Case 支出收入比率
'Case Is < 0.4
'支出收入比率得分 = 5
'Case 0.4 To 0.4999999
'支出收入比率得分 = 4
'Case 0.5 To 0.5999999
'支出收入比率得分 = 3
'Case 0.6 To 0.6999999
'支出收入比率得分 = 1
'Case Is >= 0.7
'支出收入比率得分 = 0
'End Select
If 支出收入比率 < 0.4 Then
支出收入比率得分 = 5
ElseIf 支出收入比率 >= 0.4 And 支出收入比率 < 0.5 Then
支出收入比率得分 = 4
ElseIf 支出收入比率 >= 0.5 And 支出收入比率 < 0.6 Then
支出收入比率得分 = 3
ElseIf 支出收入比率 >= 0.6 And 支出收入比率 < 0.7 Then
支出收入比率得分 = 1
Else
支出收入比率得分 = 0
End If
'Select Case 家庭资产可变现金额
'Case Is < 50000
'家庭资产可变现金额得分 = 0
'Case 50000 To 99999
'家庭资产可变现金额得分 = 1
'Case 100000 To 149999
'家庭资产可变现金额得分 = 2
'Case Is >= 150000
'家庭资产可变现金额得分 = 3
'End Select
If 家庭资产可变现金额 < 50000 Then
家庭资产可变现金额得分 = 0
ElseIf 家庭资产可变现金额 >= 50000 And 家庭资产可变现金额 < 100000 Then
家庭资产可变现金额得分 = 1
ElseIf 家庭资产可变现金额 >= 100000 And 家庭资产可变现金额 < 150000 Then
家庭资产可变现金额得分 = 2
ElseIf 家庭资产可变现金额 >= 150000 Then
家庭资产可变现金额得分 = 3
End If
.[F7] = 年龄得分
.[F8] = 健康状况得分
.[F9] = 文化程度得分
.[F10] = 经营年限得分
.[F11] = 新型农业经营主体得分
.[F12] = 住房性质得分
.[F13] = 婚姻状况得分
.[F14] = 家庭劳力得分
.[F15] = 遵纪守法得分
.[F16] = 家庭和睦得分
.[F17] = 涉诉被法院执行情况得分
.[F18] = 民间债务及民间不良信誉得分
.[F19] = 个人银行信用记录得分
.[F20] = 家庭年净收入得分
.[F21] = 家庭净资产得分
.[F22] = 资产负债率得分
.[F23] = 支出收入比率得分
.[F24] = 家庭资产可变现金额得分
End With '评分里面的表2的，嵌套
End If '评分小项的if
End With '表4的
End Sub
Sub 登记需提分小项()
Workbooks(filename).Activate '不知道哪一个工作表在激活状态。因为复选框选中哪些服务不知道。
年龄 = Sheets("农户信息经济档案-表4").[G5]
分数 = Sheets("农户信用等级评估-表2").[F27]
' If (年龄 >= 18 & 年龄 <= 60) & 分数 < 60 Then '这里年龄最好用单元格引用，因为不知道评分小项是不是也运行赋值给变量“年龄”。
If (年龄 >= 18 And 年龄 <= 60) And 分数 < 60 Then '这里年龄最好用单元格引用，因为不知道评分小项是不是也运行赋值给变量“年龄”。
MsgBox file
Dim i2 As Integer
For i2 = 1 To Workbooks.Count
If Workbooks(i2).Name = "登记需提分.xlsx" Then
h2 = 1 '这句要加上，如果第一个就遇到"登记需提分.xlsx"，就不会赋值给h2 = 0，h2为空值，也就是=0了，还是会打开"登记需提分.xlsx"。
Exit For '如果遇到 "登记需提分.xlsx"就跳出for语句
Else
h2 = 0 '做个标记，让循环结束后知道是不是没有发现"登记需提分.xlsx"。
End If
Next
If h2 = 0 Then '把打开 "/登记需提分.xlsx" 放到for外面，避免if语句没到"/登记需提分.xlsx"，就执行了else语句打开。区别在于，循环结束后才能知道有没有打开。
Dim wb3 As Workbook
Dim file3
file3 = ThisWorkbook.Path & "/登记需提分.xlsx"
Set wb3 = Application.Workbooks.Open(file3)
If wb3 Is Nothing Then MsgBox ("文件打开失败，请检查" & pth & fn & "是否存在！"): Exit Sub '这里就不用end if了，因为写在一行里面了。今天刚看到这个资料。
End If
'xlrow = Workbooks("登记需提分.xlsx").Worksheets(1).UsedRange.Rows.Count + 1
xlrow = Workbooks("登记需提分.xlsx").Worksheets(1).Range("A20000").End(xlUp).Row + 1 '不知道07版本的其他语句怎么写，不用写行号的那种。07最大行号是1048576。
Workbooks("登记需提分.xlsx").Worksheets(1).Range("A" & xlrow) = filename
Workbooks("登记需提分.xlsx").Worksheets(1).Hyperlinks.Add Anchor:=Workbooks("登记需提分.xlsx").Worksheets(1).Range("A" & xlrow), Address:=file
End If
End Sub
扫一扫 手机查看