三段代码怎么融合到一个宏按钮中？（附件已传）

stockding111

       这三段代码需要融合到一个宏按钮中，但是可能每段之间的某些定义有雷同的，出现“当前范围声明重复”的错误提示，需要改善哪几个代码设置才可以？求教老师们帮帮忙！
代码范围定义重复.zip (315.2 KB, 下载次数: 1)

2013-6-8 15:39 上传

点击文件名下载附件
精英培训论坛帮了我大忙，万分感谢！
第一段代码：
Dim n, arr, i
n = 1
arr = [bv4].Resize([bv60000].End(xlUp).Row - 1)
For i = 1 To UBound(arr)
    If IsNumeric(arr(i, 1)) Then
        Do
        If (arr(i, 1) / 6 - n * (n - 1) / 2) / n > 0 And (arr(i, 1) / 6 - n * (n - 1) / 2) / n < 1 Or n > 100 Then Exit Do
        n = n + 1
        Loop
        If n <= 100 Then arr(i, 1) = n Else arr(i, 1) = "无"
        n = 1
    Else
        arr(i, 1) = "非数值型数据"
    End If
Next i
[ca4].Resize(UBound(arr)) = arr

第二段代码：
Dim ar, i&, j&, dt As Date, br(1 To 100, 1 To 3), n&, d, x
Set d = CreateObject("scripting.dictionary")
dt = Sheets("历史对照").[BQ1]
ar = Sheets("星历表").Range("a1:au" & Sheets("星历表").Range("a" & Rows.Count).End(3).Row)
For j = 2 To 10
    d(Left(ar(1, j), 1)) = j
Next
For i = 2 To UBound(ar)
    If ar(i, 1) = dt Then
       For j = 12 To UBound(ar, 2)
           x = ar(i, j)
          If (x >= 299 And x <= 301) Or (x >= 239 And x <= 241) Or (x >= 269 And x <= 271) Or (x >= 359 And x <= 361) Or (x >= 59 And x <= 61) Or (x >= 179 And x <= 181) Or (x >= 119 And x <= 121) Or (x >= 89 And x <= 91) Or (x >= 0 And x <= 1) Then
          n = n + 1
          br(n, 1) = ar(1, j)
          br(n, 2) = ar(i, d(Left(ar(1, j), 1)))
          br(n, 3) = ar(i, d(Right(ar(1, j), 1)))
       End If
     Next
   End If
Next
Sheets("历史对照").Range("BW3:BY" & Rows.Count).ClearContents
If n > 0 Then Sheets("历史对照").Range("BW3").Resize(n, 3) = br

第三段代码：
Set dic = CreateObject("scripting.dictionary")
    With Sheets("历史对照")
        lstrow = .Range("a65536").End(3).Row
        arr = .Range("a3:aL" & lstrow)
        brr = Array(Array(0, 1, 2), Array(59, 60, 61), Array(89, 90, 91), Array(119, 120, 121), Array(179, 180, 181), Array(239, 240, 241), Array(269, 270, 271), Array(299, 300, 301))
        For a3 = LBound(brr) To UBound(brr)
            For a4 = LBound(brr(a3)) To UBound(brr(a3))
                dic(brr(a3)(a4)) = a3
            Next a4
        Next a3
        ReDim crr(1 To UBound(arr) - 1, 0 To UBound(brr) + 1)
        For r = 2 To UBound(arr)
            crr(r - 1, 0) = arr(r, 1)
            For c = 1 To UBound(arr, 2)
                If c <> 11 Then
                    If dic.exists(arr(r, c)) Then crr(r - 1, dic(arr(r, c)) + 1) = arr(1, c)
                End If
            Next c
        Next r
        Sheets("历史对照").Range("AW4").Resize(UBound(crr), UBound(crr, 2) + 1) = crr
    End With
    MsgBox "    汇总完成！"

stockding111

已解决！如下：
daima1
daima2
End Sub


Sub daima1()
Dim ar, i&, j&, dt As Date, br(1 To 100, 1 To 3), n&, d, x
Set d = CreateObject("scripting.dictionary")
dt = Sheets("历史对照").[BQ1]
ar = Sheets("星历表").Range("a1:au" & Sheets("星历表").Range("a" & Rows.Count).End(3).Row)
For j = 2 To 10
    d(Left(ar(1, j), 1)) = j
Next
For i = 2 To UBound(ar)
    If ar(i, 1) = dt Then
       For j = 12 To UBound(ar, 2)
           x = ar(i, j)
          If (x >= 299 And x <= 301) Or (x >= 239 And x <= 241) Or (x >= 269 And x <= 271) Or (x >= 359 And x <= 361) Or (x >= 59 And x <= 61) Or (x >= 179 And x <= 181) Or (x >= 119 And x <= 121) Or (x >= 89 And x <= 91) Or (x >= 0 And x <= 1) Then
          n = n + 1
          br(n, 1) = ar(1, j)
          br(n, 2) = ar(i, d(Left(ar(1, j), 1)))
          br(n, 3) = ar(i, d(Right(ar(1, j), 1)))
       End If
     Next
   End If
Next
Sheets("历史对照").Range("BW3:BY" & Rows.Count).ClearContents
If n > 0 Then Sheets("历史对照").Range("BW3").Resize(n, 3) = br
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("历史对照")
        lstrow = .Range("a65536").End(3).Row
        arr = .Range("a3:aL" & lstrow)
        brr = Array(Array(0, 1, 2), Array(59, 60, 61), Array(89, 90, 91), Array(119, 120, 121), Array(179, 180, 181), Array(239, 240, 241), Array(269, 270, 271), Array(299, 300, 301))
        For a3 = LBound(brr) To UBound(brr)
            For a4 = LBound(brr(a3)) To UBound(brr(a3))
                dic(brr(a3)(a4)) = a3
            Next a4
        Next a3
        ReDim crr(1 To UBound(arr) - 1, 0 To UBound(brr) + 1)
        For r = 2 To UBound(arr)
            crr(r - 1, 0) = arr(r, 1)
            For c = 1 To UBound(arr, 2)
                If c <> 11 Then
                    If dic.exists(arr(r, c)) Then crr(r - 1, dic(arr(r, c)) + 1) = arr(1, c)
                End If
            Next c
        Next r
        Sheets("历史对照").Range("AW4").Resize(UBound(crr), UBound(crr, 2) + 1) = crr
    End With
   
   
End Sub
Sub daima2()
    Dim n, arr, i
n = 1
arr = [bv4].Resize([bv60000].End(xlUp).Row - 1)
For i = 1 To UBound(arr)
    If IsNumeric(arr(i, 1)) Then
        Do
        If (arr(i, 1) / 6 - n * (n - 1) / 2) / n > 0 And (arr(i, 1) / 6 - n * (n - 1) / 2) / n <= 1 Or n > 1000 Then Exit Do
        n = n + 1
        Loop
        arr(i, 1) = n
        n = 1
    Else
        arr(i, 1) = "非数值"
    End If
Next i
[ca4].Resize(UBound(arr)) = arr

n = 1
arr = [bv4].Resize([bv60000].End(xlUp).Row - 1)
For i = 1 To UBound(arr)
    If IsNumeric(arr(i, 1)) Then
        Do
        If (arr(i, 1) / 8 - n * (n - 1) / 2) / n > 0 And (arr(i, 1) / 8 - n * (n - 1) / 2) / n <= 1 Or n > 1000 Then Exit Do
        n = n + 1
        Loop
        arr(i, 1) = n
        n = 1
    Else
        arr(i, 1) = "非数值"
    End If
Next i
[cb4].Resize(UBound(arr)) = arr