[已解决]怎样将循环进行到底

暴风雨一级

“分解“工作簿里有一表格，o列是村组，现要按照o列里面内容按村按组分解出来，我已分别按村按组建立建立工作簿和工作表，写代码的主要思路是通过数组、字典创建村、组，再通过嵌套循环分解到村到组，现在的主要问题是循环问题，主要卡在当第一村正常分解以后，到下一个村时，因第一次循环后，变量m已经是最大数据行了,不知道循环到下一村时怎样让变量又从1开始循环,尝试重设初始值,未达目的,特请行家指点.上传有附件
For n = 0 To UBound(arrcm)
    q = Application.WorksheetFunction.CountIf((ThisWorkbook.Sheets("面积明细表").Range("o5:o" & ThisWorkbook.Sheets("面积明细表").[a65536].End(3).Row)), arrcm(n) & "*")
    ReDim crr(1 To q, 1 To 15)
    For m = 1 To UBound(arr)
        If Left(arr(m, 15), Len(arr(m, 15)) - 3) = arrcm(n) Then
            u = u + 1
            For y = 1 To UBound(arr, 2)
                crr(u, y) = arr(m, y)
            Next
        End If
    Next
    For o = 1 To UBound(crr)
        b(Right(crr(o, 15), 2)) = ""
    Next
    arrzm = b.keys
    b.RemoveAll
    For l = 0 To UBound(arrzm)

        For r = 1 To UBound(crr)
            If Right(crr(r, 15), 2) = arrzm(l) Then
                k = k + 1
                For p = 1 To UBound(crr, 2)
                    zrr(k, p) = crr(r, p)
                Next
            End If

        Next
        For Each wb In Workbooks
            For Each sht In Worksheets
                If wb.Name = arrcm(n) & ".xls" And sht.Name = arrzm(l) Then
                    sht.Range("a5").Resize(k, 15) = zrr
                    sht.Range("c2") = arrcm(n) & "村" & arrzm(l)
                End If

            Next
        Next

        Erase arr
        k = 0
    Next
    Erase crr
    u = 0
    m = 1
Next

最佳答案

月排行榜 / 总排行榜

釜底抽薪

2022-5-31 20:48

Erase arr  这里有问题
  你把第一个村循环完了后  就把数组给清空了 你代码最前写了个 On Error Resume Next  所以就把M重置了 也不行，因为数据是空的。红色的我是添加上去的


Sub 分解1()
Application.ScreenUpdating = False
On Error Resume Next
Dim i, n, m, u, l, k, r, p, o
Dim wb As Workbook
Dim sht As Worksheet
Dim crr(), zrr(1 To 300, 1 To 15)
Set d = CreateObject("scripting.dictionary")    '提取村名

Set b = CreateObject("scripting.dictionary")    '提取组名


arr = ThisWorkbook.Sheets("面积明细表").Range("a5:o" & ThisWorkbook.Sheets("面积明细表").[a65536].End(3).Row)

For i = 1 To UBound(arr)
    d(Left(arr(i, 15), Len(arr(i, 15)) - 3)) = ""
Next

arrcm = d.keys

d.RemoveAll

For n = 0 To UBound(arrcm)
    q = Application.WorksheetFunction.CountIf((ThisWorkbook.Sheets("面积明细表").Range("o5:o" & ThisWorkbook.Sheets("面积明细表").[a65536].End(3).Row)), arrcm(n) & "*")
    ReDim crr(1 To q, 1 To 15)
    For m = 1 To UBound(arr)
        If Left(arr(m, 15), Len(arr(m, 15)) - 3) = arrcm(n) Then
            u = u + 1
            For y = 1 To UBound(arr, 2)
                crr(u, y) = arr(m, y)
            Next
        End If
    Next
    For o = 1 To UBound(crr)
        b(Right(crr(o, 15), 2)) = ""
    Next
    arrzm = b.keys
    b.RemoveAll
    For l = 0 To UBound(arrzm)

        For r = 1 To UBound(crr)
            If Right(crr(r, 15), 2) = arrzm(l) Then
                k = k + 1
                For p = 1 To UBound(crr, 2)
                    zrr(k, p) = crr(r, p)
                Next
            End If

        Next
        Dim mpath As String
        mpath = ThisWorkbook.Path & "\"
        Set wb = Workbooks.Open(mpath & arrcm(n) & ".xls")
        Set sht = wb.Sheets(arrzm(l))
'        For Each wb In Workbooks
'            For Each sht In Worksheets
'                If wb.Name = arrcm(n) & ".xls" And sht.Name = arrzm(l) Then
                    sht.Range("a5").Resize(k, 15) = zrr
                    sht.Range("c2") = arrcm(n) & "村" & arrzm(l)
                    wb.Save
                    wb.Close
'                End If
'
'            Next
'        Next

'        Erase arr
        k = 0
    Next
    Erase crr
    u = 0
Next
Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

釜底抽薪

Erase arr  这里有问题
  你把第一个村循环完了后  就把数组给清空了 你代码最前写了个 On Error Resume Next  所以就把M重置了 也不行，因为数据是空的。红色的我是添加上去的


Sub 分解1()
Application.ScreenUpdating = False
On Error Resume Next
Dim i, n, m, u, l, k, r, p, o
Dim wb As Workbook
Dim sht As Worksheet
Dim crr(), zrr(1 To 300, 1 To 15)
Set d = CreateObject("scripting.dictionary")    '提取村名

Set b = CreateObject("scripting.dictionary")    '提取组名


arr = ThisWorkbook.Sheets("面积明细表").Range("a5:o" & ThisWorkbook.Sheets("面积明细表").[a65536].End(3).Row)

For i = 1 To UBound(arr)
    d(Left(arr(i, 15), Len(arr(i, 15)) - 3)) = ""
Next

arrcm = d.keys

d.RemoveAll

For n = 0 To UBound(arrcm)
    q = Application.WorksheetFunction.CountIf((ThisWorkbook.Sheets("面积明细表").Range("o5:o" & ThisWorkbook.Sheets("面积明细表").[a65536].End(3).Row)), arrcm(n) & "*")
    ReDim crr(1 To q, 1 To 15)
    For m = 1 To UBound(arr)
        If Left(arr(m, 15), Len(arr(m, 15)) - 3) = arrcm(n) Then
            u = u + 1
            For y = 1 To UBound(arr, 2)
                crr(u, y) = arr(m, y)
            Next
        End If
    Next
    For o = 1 To UBound(crr)
        b(Right(crr(o, 15), 2)) = ""
    Next
    arrzm = b.keys
    b.RemoveAll
    For l = 0 To UBound(arrzm)

        For r = 1 To UBound(crr)
            If Right(crr(r, 15), 2) = arrzm(l) Then
                k = k + 1
                For p = 1 To UBound(crr, 2)
                    zrr(k, p) = crr(r, p)
                Next
            End If

        Next
        Dim mpath As String
        mpath = ThisWorkbook.Path & "\"
        Set wb = Workbooks.Open(mpath & arrcm(n) & ".xls")
        Set sht = wb.Sheets(arrzm(l))
'        For Each wb In Workbooks
'            For Each sht In Worksheets
'                If wb.Name = arrcm(n) & ".xls" And sht.Name = arrzm(l) Then
                    sht.Range("a5").Resize(k, 15) = zrr
                    sht.Range("c2") = arrcm(n) & "村" & arrzm(l)
                    wb.Save
                    wb.Close
'                End If
'
'            Next
'        Next

'        Erase arr
        k = 0
    Next
    Erase crr
    u = 0
Next
Application.ScreenUpdating = True
End Sub

eennoo

1. Sub marco()
   
2. Dim aDic
   
3. 
   
4. arr = ThisWorkbook.Sheets("面积明细表").Range("a5:o" & ThisWorkbook.Sheets("面积明细表").[a65536].End(3).Row)
   
5. Set aDic = CreateObject("Scripting.Dictionary")
   
6. 
   
7. For i = 1 To UBound(arr)
   
8. If arr(i, 15) Like "*村*" Then
   
9. cun = Left(arr(i, 15), InStr(arr(i, 15), "村")) '村
   
10. hao = Mid(arr(i, 15), InStr(arr(i, 15), "村") + 1) '门牌号
    
11. If Not aDic.exists(cun) Then
    
12. 
    
13. aDic.Add cun, ""
    
14. Set aDic(cun) = CreateObject("Scripting.Dictionary") '字典套字典
    
15. 
    
16. End If
    
17. '………………存放内容
    
18. If Not aDic(cun).exists(hao) Then
    
19. Dim data(1 To 1, 1 To 15)
    
20.     For y = 1 To 15
    
21.         data(1, y) = arr(i, y)
    
22.     Next
    
23.     aDic(cun)(hao) = data
    
24.    
    
25. Else
    
26. temp = aDic(cun)(hao)
    
27. ReDim Data2(1 To UBound(temp) + 1, 1 To 15)
    
28.     For x = 1 To UBound(temp)
    
29.     For y = 1 To 15
    
30.         Data2(x, y) = temp(x, y)
    
31.     Next
    
32.     Next
    
33. 
    
34.     For y = 1 To 15
    
35.         Data2(UBound(temp) + 1, y) = arr(i, y)
    
36.     Next
    
37.     aDic(cun)(hao) = Data2
    
38. End If
    
39. 
    
40. '………………
    
41. 
    
42. End If
    
43. Next
    
44. '…………接下来就很容易了
    
45. '整个大长冲村=aDic("大长冲村")
    
46. '一组 aDic("大长冲村")("一组")
    
47. For Each akey In aDic.keys
    
48.     For Each bkey In aDic(akey).keys
    
49.         '整个表格内容 aDic(akey)(bkey)
    
50.     Next
    
51. Next
    
52. 
    
53. Set aDic = Nothing
    
54. End Sub
    
55. 
    
56. 
    

复制代码

暴风雨一级

谢谢两位老师，我来消化一下

暴风雨一级

釜底抽薪 发表于 2022-5-31 20:48
Erase arr  这里有问题
  你把第一个村循环完了后  就把数组给清空了 你代码最前写了个 On Error Resume N ...

我的思路是这样的：先从全镇这个大数组arr中，生成以村为单位的新数组crr，再从数组crr中生成以组为单位的数组zrr，这样就先确实一个村有多少户、一个组又有多少户，也就确定了数组的大小，一个村一个组分解完成后，就清空数组，再开始新的循环。谢谢您了，我运行一下看。

暴风雨一级

eennoo 发表于 2022-6-1 23:55

谢谢您的辛勤付出！

釜底抽薪

暴风雨一级 发表于 2022-6-2 10:04
我的思路是这样的：先从全镇这个大数组arr中，生成以村为单位的新数组crr，再从数组crr中生成以组为单位 ...

这样没什么问题。就是在清空数组的时候 不能把基础数据数据(arr) 给清了，你的crr可以清

暴风雨一级

釜底抽薪 发表于 2022-6-2 11:15
这样没什么问题。就是在清空数组的时候 不能把基础数据数据(arr) 给清了，你的crr可以清

好的，谢谢！