某县房地一体批量出权籍套表
自用 以便后期拿来套用其中的某些代码，虽可运行，后面发现dim稍有点问题
例：Dim underline1, underline2 As Integer
应为：Dim underline1 As Integer, underline2 As Integer
主要功能有：redim 数组；选择文件夹；插入图片；加下换线；转pdf；进度条；打开文件夹等
Sub FDYT_CGB() Dim csh, hhh, hhxh, cyxha, cyxhb, dkxha, dkxhb, dkxhc, dk1, dk2, dkzs, arri As Integer Dim dkmj As Single Dim underline1, underline2 As Integer Dim rng_hu, rng_pc, rng_fbf As Range Dim arr(), gq(19), jq(19) Dim index1, index2 As Integer Dim jd1, jd2, jd3, fileopen As Integer Dim thiswkb, jzbwkb As Workbook Set thiswkb = ThisWorkbook Dim jzdsht As Worksheet Dim sht_Exist As Boolean sht_Exist = False Dim JTCY() As String Dim jz_all, xhnum, qd3_cs, W_ts As Integer Dim hunum, Twrong, chaozhan, tupian, jzdbiao, gqjq, gyr As String Dim lsxh, gqxb, jqxb As Integer Dim jzdqj() As String Dim ii%, jj% hunum = "" gqzq = "" ii = 0 jj = 0 '建文件夹 Dim Shell, myPath Dim mypathXZ, mypathC, mypathZ, filename, JDT As String Set Shell = CreateObject("Shell.Application") Set myPath = Shell.BrowseForFolder(&O0, "请选择成果表将保存的文件夹", &H1 + &H10) If Not myPath Is Nothing Then mypathXZ = myPath.self.Path & "\房地成果表" & Format$(Now(), "mmdd_hhmmss") MkDir mypathXZ Else MsgBox "未选择路径，程序退出！" Exit Sub End If Dim sc1, sc2, sc3 As Long Dim sfm1, sfm2 As String sfm2 = "正在计算..." JDT = "□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□" sc3 = 0 Application.StatusBar = False sc1 = Now() '数据开始处理 hhh = Sheets("数据").UsedRange.Rows.Count For csh = 1 To 16 Sheets(csh).Select Sheets(csh).Range("A1").Select Next For hhxh = 2 To hhh '按户主循环填表 Sheets(Array("SMS", "SQS1", "SQS2", "SJQR", "QJB-1FM", "QJB-2JB", "QJB-3JX", "QJB-4QZ", "QJB-5CT", _ "QJB-6SH", "QJB-7FH", "QJB-8FW", "QJB-9MJ", "QJB-10ZD", "QJB-11JD")).Copy After:=Sheets(Sheets.Count) '填询问笔录 Sheets(Sheets.Count - 14).Select Sheets(Sheets.Count - 14).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "声明书" Range("B4").Select ActiveCell.FormulaR1C1 = _ "声明人： " & Sheets("数据").Cells(hhxh, 2) & " ，性别： " & Sheets("数据").Cells(hhxh, 3) & " ，系 " & Sheets("数据").Cells(hhxh, 1) & " 村民，身份证号码： " & Sheets("数据").Cells(hhxh, 5) & " 。" With ActiveCell.Characters(Start:=5, Length:=Len(Sheets("数据").Cells(hhxh, 2)) + 2).Font .Underline = xlUnderlineStyleSingle End With With ActiveCell.Characters(Start:=11 + Len(Sheets("数据").Cells(hhxh, 2)), Length:=Len(Sheets("数据").Cells(hhxh, 3)) + 2).Font .Underline = xlUnderlineStyleSingle End With With ActiveCell.Characters(Start:=15 + Len(Sheets("数据").Cells(hhxh, 2)) + Len(Sheets("数据").Cells(hhxh, 3)), Length:=Len(Sheets("数据").Cells(hhxh, 1)) + 2).Font .Underline = xlUnderlineStyleSingle End With With ActiveCell.Characters(Start:=26 + Len(Sheets("数据").Cells(hhxh, 2)) + Len(Sheets("数据").Cells(hhxh, 3)) + Len(Sheets("数据").Cells(hhxh, 1)), Length:=Len(Sheets("数据").Cells(hhxh, 5)) + 2).Font .Underline = xlUnderlineStyleSingle End With '填申请书1 Sheets(Sheets.Count - 13).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "申请书1" If Mid(Sheets("数据").Cells(hhxh, 6), 13, 2) = "JB" Then Sheets(Sheets.Count - 13).Cells(5, 2) = Sheets(Sheets.Count - 13).Cells(4, 1) Sheets(Sheets.Count - 13).Cells(4, 1) = "" End If Sheets(Sheets.Count - 13).Cells(2, 6) = Sheets("数据").Cells(hhxh, 36) Sheets(Sheets.Count - 13).Cells(8, 4) = Sheets("数据").Cells(hhxh, 2) Sheets(Sheets.Count - 13).Cells(9, 4) = Sheets("数据").Cells(hhxh, 4) Sheets(Sheets.Count - 13).Cells(9, 7) = Sheets("数据").Cells(hhxh, 5) Sheets(Sheets.Count - 13).Cells(10, 4) = Sheets("数据").Cells(hhxh, 1) 'Sheets(Sheets.Count - 13).Cells(11, 4) = Sheets("数据").Cells(hhxh, 3) 'Sheets(Sheets.Count - 13).Cells(11, 7) = Sheets("数据").Cells(hhxh, 41) Sheets(Sheets.Count - 13).Cells(21, 4) = Sheets("数据").Cells(hhxh, 1) Sheets(Sheets.Count - 13).Cells(22, 4) = Sheets("数据").Cells(hhxh, 39) Sheets(Sheets.Count - 13).Cells(23, 4) = Format$(Sheets("数据").Cells(hhxh, 27), "0.00") & "；" & Format$(Sheets("数据").Cells(hhxh, 30), "0.00") Sheets(Sheets.Count - 13).Cells(23, 8) = Sheets("数据").Cells(hhxh, 25) '填申请书2 Sheets(Sheets.Count - 12).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "申请书2" Sheets(Sheets.Count - 12).Cells(15, 3) = Sheets("数据").Cells(hhxh, 2) Sheets(Sheets.Count - 12).Cells(15, 4) = Sheets("数据").Cells(hhxh, 5) Sheets(Sheets.Count - 12).Cells(15, 6) = Replace(Sheets("数据").Cells(hhxh, 1), "松潘县", "") If Sheets("数据").Cells(hhxh, 32) <> "" Then ReDim JTCY(0 To UBound(Split(Sheets("数据").Cells(hhxh, 32), "/"))) JTCY = Split(Sheets("数据").Cells(hhxh, 32), "/") For xhnum = 0 To UBound(JTCY) Sheets(Sheets.Count - 12).Cells(16 + xhnum, 3) = Left(JTCY(xhnum), InStr(JTCY(xhnum), "-") - 1) If Right(JTCY(xhnum), Len(JTCY(xhnum)) - InStr(JTCY(xhnum), "+")) <> "BB" Then Sheets(Sheets.Count - 12).Cells(16 + xhnum, 4) = Right(JTCY(xhnum), Len(JTCY(xhnum)) - InStr(JTCY(xhnum), "+")) End If Sheets(Sheets.Count - 12).Cells(16 + xhnum, 6) = Replace(Sheets("数据").Cells(hhxh, 1), "松潘县", "") If Mid(JTCY(xhnum), InStr(JTCY(xhnum), "-") + 1, InStr(JTCY(xhnum), "+") - InStr(JTCY(xhnum), "-") - 1) <> "AA" Then Sheets(Sheets.Count - 12).Cells(16 + xhnum, 8) = Mid(JTCY(xhnum), InStr(JTCY(xhnum), "-") + 1, InStr(JTCY(xhnum), "+") - InStr(JTCY(xhnum), "-") - 1) Else Sheets(Sheets.Count - 12).Cells(16 + xhnum, 8) = "成员" End If If xhnum > 10 Then Exit For End If Next End If '申请审批表 Sheets(Sheets.Count - 11).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "批准表" Sheets(Sheets.Count - 11).Cells(2, 2) = " 我（" & Left(Sheets(Sheets.Count - 13).Cells(6, 2), 1) & "是或 □否）本集体经济组织成员，共有产权人" _ & Sheets("数据").Cells(hhxh, 34) & "人，于" & Sheets("数据").Cells(hhxh, 50) & "自建房屋，占地面积" & Format$(Sheets("数据").Cells(hhxh, 27), "0.00") _ & "平方米，建筑面积" & Format$(Sheets("数据").Cells(hhxh, 30), "0.00") & "平方米，建成至今无宅基地及建房审批手续且未翻改建，" _ & "四至界线无争议，房屋能够长期安全使用，对房屋预期安全问题造成的一切损失由我自行承担。现申请对本人宅基地使用权和房屋所有权进行确权登记。" Sheets(Sheets.Count - 11).Cells(13, 2) = " 按照公示情况，权属来源证明材料、经初步审查，该户符合农村村民建房条件，不占永久性基本农田，结合户籍人口数综合判定该户合法宅基地面积" _ & Format$(Sheets("数据").Cells(hhxh, 28), "0.00") & "平方米，建筑面积" & Format$(Sheets("数据").Cells(hhxh, 31), "0.00") & "平方米。" '权籍调查表1 Sheets(Sheets.Count - 10).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "权调封面" Sheets(Sheets.Count - 10).Cells(5, 2) = "宗地/宗海代码：" & Sheets("数据").Cells(hhxh, 6) Sheets(Sheets.Count - 10).Cells(9, 2) = "调查时间： " & Sheets("数据").Cells(hhxh, 38) '权籍调查表2 Sheets(Sheets.Count - 9).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "权调表" Sheets(Sheets.Count - 9).Cells(4, 3) = Sheets("数据").Cells(hhxh, 2) Sheets(Sheets.Count - 9).Cells(5, 12) = Sheets("数据").Cells(hhxh, 4) Sheets(Sheets.Count - 9).Cells(6, 12) = Sheets("数据").Cells(hhxh, 5) Sheets(Sheets.Count - 9).Cells(7, 12) = Sheets("数据").Cells(hhxh, 1) Sheets(Sheets.Count - 9).Cells(8, 15) = Sheets("数据").Cells(hhxh, 9) Sheets(Sheets.Count - 9).Cells(9, 3) = Sheets("数据").Cells(hhxh, 1) Sheets(Sheets.Count - 9).Cells(16, 3) = Sheets("数据").Cells(hhxh, 6) Sheets(Sheets.Count - 9).Cells(16, 11) = Sheets("数据").Cells(hhxh, 6) Sheets(Sheets.Count - 9).Cells(19, 4) = Sheets("数据").Cells(hhxh, 10) Sheets(Sheets.Count - 9).Cells(20, 3) = "北：" & Sheets("数据").Cells(hhxh, 13) Sheets(Sheets.Count - 9).Cells(21, 3) = "东：" & Sheets("数据").Cells(hhxh, 16) Sheets(Sheets.Count - 9).Cells(22, 3) = "南：" & Sheets("数据").Cells(hhxh, 19) Sheets(Sheets.Count - 9).Cells(23, 3) = "西：" & Sheets("数据").Cells(hhxh, 22) Sheets(Sheets.Count - 9).Cells(25, 3) = Sheets("数据").Cells(hhxh, 23) Sheets(Sheets.Count - 9).Cells(26, 4) = Sheets("数据").Cells(hhxh, 24) Sheets(Sheets.Count - 9).Cells(25, 10) = Sheets("数据").Cells(hhxh, 25) Sheets(Sheets.Count - 9).Cells(26, 15) = Sheets("数据").Cells(hhxh, 26) Sheets(Sheets.Count - 9).Cells(27, 3) = Format$(Sheets("数据").Cells(hhxh, 28), "0.00") Sheets(Sheets.Count - 9).Cells(27, 7) = Format$(Sheets("数据").Cells(hhxh, 27), "0.00") Sheets(Sheets.Count - 9).Cells(27, 15) = Format$(Sheets("数据").Cells(hhxh, 29), "0.00") Sheets(Sheets.Count - 9).Cells(28, 15) = Format$(Sheets("数据").Cells(hhxh, 30), "0.00") gyr = Sheets(Sheets.Count - 12).Cells(15, 3) For xhnum = 16 To 26 If Sheets(Sheets.Count - 12).Cells(xhnum, 3) <> "" Then gyr = gyr & "，" & Sheets(Sheets.Count - 12).Cells(xhnum, 3) Else Exit For End If Next Sheets(Sheets.Count - 9).Cells(30, 3) = " " & gyr If Sheets("数据").Cells(hhxh, 33) <> "" Then Sheets(Sheets.Count - 9).Cells(31, 3) = " 该处宅基地使用权及房屋所有权为" & Sheets("数据").Cells(hhxh, 33) End If '权籍调查表3(界标) Sheets(Sheets.Count - 8).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "界标表" Sheets(Sheets.Count - 8).Select Sheets(Sheets.Count - 8).Cells(4, 1) = "J1" Sheets(Sheets.Count - 8).Cells(4, 4) = "√" Sheets(Sheets.Count - 8).Cells(60, 1) = "J27" Sheets(Sheets.Count - 8).Cells(60, 4) = "√" hunum = "A" & Sheets("数据").Cells(hhxh, 6) With Sheets("界址").Cells Set rng_hu = .Find(What:=hunum, LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False) End With If (Not rng_hu Is Nothing) Then For xhnum = 2 To 200 If Sheets("界址").Cells(rng_hu.Row, xhnum) = "" Then Exit For End If Next jz_all = xhnum / 2 - 1 xhnum = 0 If jz_all > 52 Then Twrong = Twrong & hunum & "行，" & Sheets("数据").Cells(hhxh, 6) & " 界址点数超过两页，请自行完善成果表！" & Chr(13) jz_all = 52 ElseIf jz_all < 27 Then Sheets(Sheets.Count - 8).Rows("57:113").Select Selection.Delete Shift:=xlUp Sheets(Sheets.Count - 8).Range("A1").Select End If For lsxh = 0 To 19 gq(lsxh) = 1000 jq(lsxh) = 1000 Next gqxb = 0 jqxb = 0 gqjq = Sheets("数据").Cells(hhxh, 52) & Sheets("数据").Cells(hhxh, 53) & Sheets("数据").Cells(hhxh, 54) & Sheets("数据").Cells(hhxh, 55) If InStr(gqjq, "共墙") <> 0 Or InStr(gqjq, "借墙") <> 0 Then For xhnum = 52 To 55 If Sheets("数据").Cells(hhxh, xhnum) = "共墙" And Sheets("数据").Cells(hhxh, xhnum + 4) <> "" Then jzdqj = VBA.Split(Trim(Sheets("数据").Cells(hhxh, xhnum + 4).Value), "-") If Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) < Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) Then 'ReDim gq(Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - 1) For lsxh = gqxb To Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - 1 + gqxb gq(lsxh) = Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) + 1 + lsxh - gqxb Next gqxb = lsxh - 1 ElseIf Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) > Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) Then 'ReDim gq(jz_all + Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - 1) For lsxh = gqxb To jz_all + Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - 1 If Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) + 1 + lsxh - gqxb < jz_all + 2 Then gq(lsxh) = Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) + 1 + lsxh - gqxb Else gq(lsxh) = lsxh - gqxb End If Next gqxb = lsxh Else Twrong = Twrong & hhxh & "行，" & Sheets("数据").Cells(hhxh, 6) & " 填写共墙界址点有误，请自行完善！" & Chr(13) End If End If If Sheets("数据").Cells(hhxh, xhnum) = "借墙" And Sheets("数据").Cells(hhxh, xhnum + 4) <> "" Then jzdqj = VBA.Split(Trim(Sheets("数据").Cells(hhxh, xhnum + 4).Value), "-") If Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) < Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) Then 'ReDim gq(Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - 1) For lsxh = jqxb To Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - 1 jq(lsxh) = Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) + 1 + lsxh - jqxb Next jqxb = lsxh - 1 ElseIf Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) > Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) Then 'ReDim gq(jz_all + Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - 1) For lsxh = jqxb To jz_all + Int(Right(jzdqj(1), Len(jzdqj(1)) - 1)) - Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) - 1 If Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) + 1 + lsxh - jqxb < jz_all + 2 Then jq(lsxh) = Int(Right(jzdqj(0), Len(jzdqj(0)) - 1)) + 1 + lsxh - jqxb Else jq(lsxh) = lsxh - jqxb End If Next jqxb = lsxh Else Twrong = Twrong & hhxh & "行，" & Sheets("数据").Cells(hhxh, 6) & " 填写借墙界址点有误，请自行完善！" & Chr(13) End If End If Next End If If jz_all < 27 Then For xhnum = 1 To jz_all Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 7) = Sheets("界址").Cells(rng_hu.Row, xhnum * 2) If Sheets("界址").Cells(rng_hu.Row, xhnum * 2 + 1).Value = "143130" Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 15) = "√" Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 17) = "√" ElseIf Sheets("界址").Cells(rng_hu.Row, xhnum * 2 + 1).Value = "JZX" Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 8) = "√" Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 17) = "√" Else Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 14) = "√" On Error Resume Next ii = WorksheetFunction.Match(xhnum + 1, gq, 0) jj = WorksheetFunction.Match(xhnum + 1, jq, 0) If ii > 0 Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 17) = "√" ElseIf jj > 0 Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 16) = "√" Else Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2, 18) = "√" End If End If If xhnum = jz_all Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3, 1) = "J1" Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3, 4) = "√" Else Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3, 1) = "J" & xhnum + 1 Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3, 4) = "√" End If ii = 0 jj = 0 Next Else For xhnum = 1 To jz_all If xhnum < 27 Then qd3_cs = 0 Else qd3_cs = 4 End If Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 7) = Sheets("界址").Cells(rng_hu.Row, xhnum * 2) If Sheets("界址").Cells(rng_hu.Row, xhnum * 2 + 1).Value = "143130" Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 15) = "√" Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 17) = "√" ElseIf Sheets("界址").Cells(rng_hu.Row, xhnum * 2 + 1).Value = "JZX" Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 8) = "√" Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 17) = "√" Else Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 14) = "√" On Error Resume Next ii = WorksheetFunction.Match(xhnum + 1, gq, 0) jj = WorksheetFunction.Match(xhnum + 1, jq, 0) If ii > 0 Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 17) = "√" ElseIf jj > 0 Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 16) = "√" Else Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 2 + qd3_cs, 18) = "√" End If End If If xhnum = jz_all Then Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3 + qd3_cs, 1) = "J1" Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3 + qd3_cs, 4) = "√" Else Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3 + qd3_cs, 1) = "J" & xhnum + 1 Sheets(Sheets.Count - 8).Cells(xhnum * 2 + 3 + qd3_cs, 4) = "√" End If ii = 0 jj = 0 Next End If End If '权籍调查表4(签章表) Sheets(Sheets.Count - 7).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "签章表" Sheets(Sheets.Count - 7).Cells(4, 1) = Sheets("数据").Cells(hhxh, 11) Sheets(Sheets.Count - 7).Cells(4, 2) = Sheets("数据").Cells(hhxh, 12) Sheets(Sheets.Count - 7).Cells(4, 3) = Sheets("数据").Cells(hhxh, 14) Sheets(Sheets.Count - 7).Cells(4, 4) = Sheets("数据").Cells(hhxh, 13) Sheets(Sheets.Count - 7).Cells(5, 1) = Sheets("数据").Cells(hhxh, 14) Sheets(Sheets.Count - 7).Cells(5, 2) = Sheets("数据").Cells(hhxh, 15) Sheets(Sheets.Count - 7).Cells(5, 3) = Sheets("数据").Cells(hhxh, 17) Sheets(Sheets.Count - 7).Cells(5, 4) = Sheets("数据").Cells(hhxh, 16) Sheets(Sheets.Count - 7).Cells(6, 1) = Sheets("数据").Cells(hhxh, 17) Sheets(Sheets.Count - 7).Cells(6, 2) = Sheets("数据").Cells(hhxh, 18) Sheets(Sheets.Count - 7).Cells(6, 3) = Sheets("数据").Cells(hhxh, 20) Sheets(Sheets.Count - 7).Cells(6, 4) = Sheets("数据").Cells(hhxh, 19) Sheets(Sheets.Count - 7).Cells(7, 1) = Sheets("数据").Cells(hhxh, 20) Sheets(Sheets.Count - 7).Cells(7, 2) = Sheets("数据").Cells(hhxh, 21) Sheets(Sheets.Count - 7).Cells(7, 3) = Sheets("数据").Cells(hhxh, 11) Sheets(Sheets.Count - 7).Cells(7, 4) = Sheets("数据").Cells(hhxh, 22) '权籍调查表5(宗地草图) Sheets(Sheets.Count - 6).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "草图" Set rng_pc = Sheets(Sheets.Count - 6).Cells(1, 1) tupian = ThisWorkbook.Path & "\JPG\宗地草图JPG\" & Sheets("数据").Cells(hhxh, 6) & ".jpg" If Not Dir(tupian, vbDirectory) = vbNullString Then Sheets(Sheets.Count - 6).Shapes.AddPicture tupian, True, True, rng_pc.Left + 2, rng_pc.Top + 20, rng_pc.Width - 4, rng_pc.Height * 2 - 40 Else Twrong = Twrong & hhxh & "行，" & Sheets("数据").Cells(hhxh, 6) & " 未找到对应的宗地草图，请自行完善！" & Chr(13) End If '权籍调查表6(审核表) Sheets(Sheets.Count - 5).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "审核表" Sheets(Sheets.Count - 5).Cells(4, 4) = "日期：" & Sheets("数据").Cells(hhxh, 38) Sheets(Sheets.Count - 5).Cells(6, 4) = "日期：" & Sheets("数据").Cells(hhxh, 38) Sheets(Sheets.Count - 5).Cells(2, 2) = " 本次调查依据土地利用现状定界，共设置界址点 " & jz_all & _ " 个，本宗地合法指界人对界线无异议，并在本表签字认可，邻宗地合法指界人对指界无异议，并在本表签字认可。" '权籍调查表7(分户图) Sheets(Sheets.Count - 4).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "分户图" Set rng_pc = Sheets(Sheets.Count - 4).Cells(1, 1) tupian = ThisWorkbook.Path & "\JPG\分户图JPG\" & Sheets("数据").Cells(hhxh, 6) & ".jpg" If Not Dir(tupian, vbDirectory) = vbNullString Then Sheets(Sheets.Count - 4).Shapes.AddPicture tupian, True, True, rng_pc.Left + 2, rng_pc.Top + 10, rng_pc.Width - 4, rng_pc.Height * 2 - 20 Else Twrong = Twrong & hhxh & "行，" & Sheets("数据").Cells(hhxh, 6) & " 未找到对应的分户图，请自行完善！" & Chr(13) End If '权籍调查表8(房屋信息) Sheets(Sheets.Count - 3).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "房屋表" Sheets(Sheets.Count - 3).Cells(2, 1) = "市区名称或代码 " & Left(Sheets("数据").Cells(hhxh, 6), 6) Sheets(Sheets.Count - 3).Cells(2, 6) = "地籍区 " & Mid(Sheets("数据").Cells(hhxh, 6), 7, 3) Sheets(Sheets.Count - 3).Cells(2, 11) = "地籍子区 " & Mid(Sheets("数据").Cells(hhxh, 6), 10, 3) Sheets(Sheets.Count - 3).Cells(2, 14) = "宗地号 " & Mid(Sheets("数据").Cells(hhxh, 6), 13, 7) Sheets(Sheets.Count - 3).Cells(2, 19) = "定着物（房屋）代码 " & Mid(Sheets("数据").Cells(hhxh, 39), 20, 9) Sheets(Sheets.Count - 3).Cells(3, 3) = Sheets("数据").Cells(hhxh, 39) Sheets(Sheets.Count - 3).Cells(4, 2) = Sheets("数据").Cells(hhxh, 1) Sheets(Sheets.Count - 3).Cells(4, 18) = Sheets("数据").Cells(hhxh, 40) Sheets(Sheets.Count - 3).Cells(5, 2) = Sheets("数据").Cells(hhxh, 2) Sheets(Sheets.Count - 3).Cells(5, 14) = Sheets("数据").Cells(hhxh, 4) Sheets(Sheets.Count - 3).Cells(6, 14) = Sheets("数据").Cells(hhxh, 5) Sheets(Sheets.Count - 3).Cells(7, 2) = Sheets("数据").Cells(hhxh, 41) Sheets(Sheets.Count - 3).Cells(7, 12) = Sheets("数据").Cells(hhxh, 1) Sheets(Sheets.Count - 3).Cells(8, 2) = Sheets("数据").Cells(hhxh, 42) Sheets(Sheets.Count - 3).Cells(9, 2) = Sheets("数据").Cells(hhxh, 43) Sheets(Sheets.Count - 3).Cells(9, 12) = Sheets("数据").Cells(hhxh, 44) Sheets(Sheets.Count - 3).Cells(10, 2) = Sheets("数据").Cells(hhxh, 45) 'Sheets(Sheets.Count - 3).Cells(8, 16) = Sheets("数据").Cells(hhxh, 46) Sheets(Sheets.Count - 3).Cells(13, 5) = Sheets("数据").Cells(hhxh, 47) Sheets(Sheets.Count - 3).Cells(13, 6) = Sheets("数据").Cells(hhxh, 48) Sheets(Sheets.Count - 3).Cells(13, 9) = Sheets("数据").Cells(hhxh, 49) Sheets(Sheets.Count - 3).Cells(13, 10) = Sheets("数据").Cells(hhxh, 50) Sheets(Sheets.Count - 3).Cells(13, 12) = Format$(Sheets("数据").Cells(hhxh, 29), "0.00") Sheets(Sheets.Count - 3).Cells(13, 13) = Format$(Sheets("数据").Cells(hhxh, 30), "0.00") Sheets(Sheets.Count - 3).Cells(13, 19) = Sheets("数据").Cells(hhxh, 51) Sheets(Sheets.Count - 3).Cells(13, 20) = Sheets("数据").Cells(hhxh, 52) Sheets(Sheets.Count - 3).Cells(13, 21) = Sheets("数据").Cells(hhxh, 53) Sheets(Sheets.Count - 3).Cells(13, 22) = Sheets("数据").Cells(hhxh, 54) Sheets(Sheets.Count - 3).Cells(13, 23) = Sheets("数据").Cells(hhxh, 55) Sheets(Sheets.Count - 3).Cells(17, 19) = "日期：" & Sheets("数据").Cells(hhxh, 38) '权籍调查表9(面积表) Sheets(Sheets.Count - 2).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "面积表" Sheets(Sheets.Count - 2).Cells(3, 4) = Sheets("数据").Cells(hhxh, 2) Sheets(Sheets.Count - 2).Cells(3, 8) = Sheets("数据").Cells(hhxh, 6) Sheets(Sheets.Count - 2).Cells(3, 11) = Sheets("数据").Cells(hhxh, 1) Sheets(Sheets.Count - 2).Cells(6, 14) = Format$(Sheets("数据").Cells(hhxh, 27), "0.00") Sheets(Sheets.Count - 2).Cells(9, 14) = Format$(Sheets("数据").Cells(hhxh, 27), "0.00") If Format$(Sheets("数据").Cells(hhxh, 27), "0.00") = Format$(Sheets("数据").Cells(hhxh, 28), "0.00") Then Sheets(Sheets.Count - 2).Cells(10, 1) = "备注：该宗地批准面积为" & Format$(Sheets("数据").Cells(hhxh, 28), "0.00") & "㎡，超占土地面积为0㎡。" Else chaozhan = Format$(Sheets("数据").Cells(hhxh, 27) - Sheets("数据").Cells(hhxh, 28), "0.00") Sheets(Sheets.Count - 2).Cells(10, 1) = "备注：该宗地批准面积为" & Format$(Sheets("数据").Cells(hhxh, 28), "0.00") & "㎡，超占土地面积为" & chaozhan & "㎡。" End If Sheets(Sheets.Count - 2).Cells(12, 12) = Sheets("数据").Cells(hhxh, 38) '权籍调查表10(宗地图) Sheets(Sheets.Count - 1).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "宗地图" Set rng_pc = Sheets(Sheets.Count - 1).Cells(1, 1) tupian = ThisWorkbook.Path & "\JPG\宗地图JPG\" & Sheets("数据").Cells(hhxh, 6) & ".jpg" If Not Dir(tupian, vbDirectory) = vbNullString Then Sheets(Sheets.Count - 1).Shapes.AddPicture tupian, True, True, rng_pc.Left + 2, rng_pc.Top + 15, rng_pc.Width - 4, rng_pc.Height * 2 - 30 Else Twrong = Twrong & hhxh & "行，" & Sheets("数据").Cells(hhxh, 6) & " 未找到对应的宗地图，请自行完善！" & Chr(13) End If '权籍调查表11(界址点成果表) 'Sheets(Sheets.Count - 1).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 3) & "界点表" jzdbiao = ThisWorkbook.Path & "\界址点成果表.xlsx" If hhxh = 2 Then If Not Dir(jzdbiao, vbDirectory) = vbNullString Then Set jzdwkb = Workbooks.Open(jzdbiao) thiswkb.Activate Else MsgBox jzdbiao & Chr(13) & "界址点表不存在或命名不正确，请自行完善后重新运行该程序！" Exit Sub End If End If For Each jzdsht In jzdwkb.Worksheets If jzdsht.Name = Sheets("数据").Cells(hhxh, 6) Then sht_Exist = True Exit For End If Next jzdsht If sht_Exist Then jzdwkb.Worksheets(thiswkb.Worksheets("数据").Cells(hhxh, 6).Value).Copy Before:=thiswkb.Worksheets(thiswkb.Worksheets.Count) Sheets(Sheets.Count - 1).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "界点表" Application.DisplayAlerts = False Sheets(Sheets.Count).Delete Application.DisplayAlerts = True sht_Exist = False Else Sheets(Sheets.Count).Name = Sheets("数据").Cells(hhxh, 6) & Sheets("数据").Cells(hhxh, 2) & "界点表(无)" Twrong = Twrong & hunum & "行，" & Sheets("数据").Cells(hhxh, 6) & " 未找到对应的界址点成果表，请自行完善！" & Chr(13) End If '数据分组存储 ' If hhxh = 2 Then ' MkDir mypathXZ & Left(Sheets(Sheets.Count).Cells(3, 3), 4) ' End If If Sheets("数据").Cells(hhxh, 1) <> Sheets("数据").Cells(hhxh + 1, 1) Then filename = mypathXZ & "\" & Sheets("数据").Cells(hhxh, 1) & hhxh & ".xlsx" ReDim arr(Sheets.Count - 18) For arri = 18 To Sheets.Count arr(arri - 18) = arri Next Sheets(arr).Move '添加目录索引 Sheets(1).Select Sheets.Add Sheets(1).Name = "目录" index1 = 2 Sheets(1).Cells(1, 1) = "序号" Sheets(1).Cells(1, 2) = "目录" For index2 = 2 To ActiveWorkbook.Worksheets.Count Sheets(1).Cells(index1, 1) = index1 - 1 Sheets(1).Cells(index1, 2) = Sheets(index2).Name ActiveSheet.Hyperlinks.Add Anchor:=Sheets(1).Cells(index1, 2), Address:="", SubAddress:="'" & Worksheets(index2).Name & "'!A1", _ ScreenTip:="单击进入: " & Worksheets(index2).Name index1 = index1 + 1 Next ActiveWorkbook.SaveAs filename:=filename, FileFormat:=xlOpenXMLWorkbook Application.DisplayAlerts = False ActiveWorkbook.Sheets(1).Delete Application.DisplayAlerts = True ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, filename:=Left(filename, Len(filename) - 5) & ".pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ' ActiveWorkbook.SaveAs filename:=Left(filename, Len(filename) - 5) & ".pdf", FileFormat:=17 ActiveWorkbook.Close False End If '进度条 JDT = "" jd1 = VBA.Int(hhxh / hhh * 50) For jd2 = 1 To 50 If jd2 < jd1 + 1 Then JDT = JDT & "■" Else JDT = JDT & "□" End If Next Application.StatusBar = "程序运行进度 " & JDT & VBA.Format$(hhxh / hhh, "0.0%") & "！" Next jzdwkb.Close sc2 = Now() 'sc3 = Round((sc2 - sc1) * 86400 / (hhh - 1), 2) Application.StatusBar = "程序运行时间：" & Round((sc2 - sc1) * 86400, 2) & "秒，运行速度：" & Round((sc2 - sc1) * 86400 / (hhh - 1), 2) & "秒/条！" If Twrong <> "" Then W_ts = MsgBox(Twrong, vbOKOnly, "以下问题，请核实修改：") End If fileopen = MsgBox("程序完成，数据已保存在:" & mypathXZ & " 下，" _ & Chr(13) & "是否现在打开该文件夹？", vbYesNo) If fileopen = 6 Then VBA.Shell "explorer " & mypathXZ, vbNormalFocus End If Application.StatusBar = False Sheets(1).Select End Sub
