较为复杂的批量分表问题，望各位大侠相助

Comet_95

原数据为透视表，需要每个村的数据分到不同的三个表中，且村内数据没有一定的规律。效果详见附件。诸位可作出一个表的代码，我细细参考。

原数据

表1

Comet_95

诸位江湖大侠，附件下方

microyip

1. Sub 生成数据()
   
2.     Dim dicData As Object
   
3.     Dim vData As Variant, nRow As Integer, vFill As Variant
   
4.     Dim vVillage As Variant, vType As Variant, sData As String, sType As String
   
5.     Dim wSH As Worksheet, vSH As Variant
   
6.     Dim dicSH As Object, vCol As Variant, nCol As Integer
   
7.    
   
8.     Application.ScreenUpdating = False
   
9.     Application.DisplayAlerts = False
   
10.    
    
11.     vData = Sheet1.UsedRange.Value
    
12.     Set dicData = CreateObject("Scripting.Dictionary")
    
13.     For nRow = 1 To UBound(vData)
    
14.         sData = Trim(vData(nRow, 1))
    
15.         vType = Trim(vData(nRow, 2))
    
16.         If sData = "" Or sData Like "*村" Then
    
17.             If sData <> "" Then
    
18.                 vVillage = sData
    
19.                 Set dicData(vVillage) = CreateObject("Scripting.Dictionary")
    
20.             End If
    
21.             If vType <> "" Then dicData(vVillage)(vType) = Val(vData(nRow, 3))
    
22.         End If
    
23.     Next
    
24.     With Workbooks.Open(ThisWorkbook.Path & "\模版.xlsx")
    
25.         Set dicSH = CreateObject("Scripting.Dictionary")
    
26.         For Each wSH In .Sheets
    
27.             vSH = vSH + 1
    
28.             If wSH.Name Like "*农用地*" Or wSH.Name Like "*建设用地*" Or wSH.Name Like "*未利用地*" Then
    
29.                 Set dicSH(vSH) = CreateObject("Scripting.Dictionary")
    
30.                 vData = wSH.UsedRange.Value
    
31.                 For nRow = 9 To UBound(vData)
    
32.                     If vData(nRow, 1) Like "相关事项说明*" Then
    
33.                         nRow = nRow - 1
    
34.                         Exit For
    
35.                     Else
    
36.                         sType = Trim(Replace(vData(nRow, 2), " ", ""))
    
37.                         For Each vType In dicData(vVillage).Keys
    
38.                             If sType Like "*" & vType Then
    
39.                                 vData(nRow - 8, 1) = vType
    
40.                                 Exit For
    
41.                             End If
    
42.                         Next
    
43.                     End If
    
44.                 Next
    
45.                 If nRow > UBound(vData) Then nRow = nRow - 1
    
46.                 ReDim vFill(1 To nRow - 8, 1 To UBound(vData, 2) - 2)
    
47.                 dicSH(vSH)("填写数据") = vFill
    
48.                 ReDim Preserve vData(1 To UBound(vData), 1 To 1)
    
49.                 vData = Application.WorksheetFunction.Transpose(vData)
    
50.                 ReDim Preserve vData(1 To nRow - 8)
    
51.                 If wSH.Name Like "*农用地*" Then
    
52.                     dicSH(vSH)("填数据列") = Array(2, 9)
    
53.                 ElseIf wSH.Name Like "*建设用地*" Then
    
54.                     dicSH(vSH)("填数据列") = Array(2, 13)
    
55.                 Else
    
56.                     dicSH(vSH)("填数据列") = Array(1)
    
57.                 End If
    
58.                 dicSH(vSH)("数据") = vData
    
59.                 dicSH(vSH)("最后一行") = nRow
    
60.             End If
    
61.         Next
    
62.         For Each vVillage In dicData.Keys
    
63.             sData = "     乡镇（街）" & vVillage & "（居）      组                          201  年   月  日                                         单位：亩、立方米、元"
    
64.             For Each vSH In dicSH.Keys
    
65.                 vCol = dicSH(vSH)("填数据列")
    
66.                 nRow = dicSH(vSH)("最后一行")
    
67.                 vData = dicSH(vSH)("数据")
    
68.                 vFill = dicSH(vSH)("填写数据")
    
69.                 For nRow = 1 To UBound(vFill)
    
70.                     vType = vData(nRow)
    
71.                     If dicData(vVillage).Exists(vType) Then
    
72.                         nCol = 0
    
73.                         Do While nCol <= UBound(vCol)
    
74.                             If nRow > 1 Then vFill(nRow, vCol(nCol)) = dicData(vVillage)(vType)
    
75.                             vFill(1, vCol(nCol)) = vFill(1, vCol(nCol)) + dicData(vVillage)(vType)
    
76.                             nCol = nCol + 1
    
77.                         Loop
    
78.                     End If
    
79.                 Next
    
80.                 With .Sheets(vSH)
    
81.                     .[A4] = sData
    
82.                     .[C9].Resize(UBound(vFill), UBound(vFill, 2)) = vFill
    
83.                 End With
    
84.             Next
    
85.             .SaveAs ThisWorkbook.Path & "\结果" & vVillage & ".xlsx"
    
86.         Next
    
87.         .Close False
    
88.     End With
    
89.     Application.DisplayAlerts = True
    
90.     Application.ScreenUpdating = True
    
91. End Sub

复制代码

microyip

附上附件以供参考

opiona

Excel 工作簿汇总，工作表汇总合并，多文件汇总合并 通用代码 支持多层子文件夹-

http://club.excelhome.net/thread-1409141-1-1.html

Comet_95

microyip 发表于 2018-7-22 16:18
附上附件以供参考

醍醐灌顶,但有一个小问题,外承包面积要放到出租经营里,如何改动?

不知道为什么

Comet_95 发表于 2018-7-24 11:15
醍醐灌顶,但有一个小问题,外承包面积要放到出租经营里,如何改动?

老师写出的代码2天后才反馈？不说其他，就那么多代码，先给下评分，也是对别人的尊重吧！再说如果真看明白，醍醐灌顶，你那个新的需求自己就能解决！