求大神修改

xiaomaowangcai · 发表于 2019-10-6 12:22

求大神修改，谢谢·····

liulang0808 · 发表于 2019-10-6 14:36

Sub 按年龄统计()
Application.ScreenUpdating = False '
Dim ar As Variant
Dim cr
Dim i As Long
Dim n As Long
Dim m As Long
' ReDim cr(1 To 2, 1 To 10) '
cr = Sheets("问题二").[b6].Resize(2, 10)
For Each sh In Sheets '
      If InStr(sh.Name, "数据") > 0 Then '
         ar = sh.Range("a1").CurrentRegion '
         If sh.Name = "数据库一" Then '
            nl = 7 '
            hs = 2 ''
            xb = 3 ''
            rk = 4
         Else '
            nl = 9 '
            hs = 4
            xb = 5
            rk = 6
         End If '
         For i = 3 To UBound(ar) '
            If Len(Trim(ar(i, nl))) <> 0 Then '
                  If ar(i, nl) >= 50 Then
                     cr(1, 1) = cr(1, 1) + ar(i, hs)
                     cr(1, 2) = cr(1, 2) + ar(i, rk)
                  End If
                  If ar(i, nl) >= 50 And Trim(ar(i, xb)) = "女" Then
                     cr(1, 5) = cr(1, 5) + ar(i, hs)
                     cr(1, 6) = cr(1, 6) + ar(i, rk)
                  ElseIf ar(i, nl) >= 50 And Trim(ar(i, xb)) = "男" Then
                     cr(1, 9) = cr(1, 9) + ar(i, hs)
                     cr(1, 10) = cr(1, 10) + ar(i, rk)
                  End If

                  If ar(i, nl) < 45 Then
                     cr(2, 1) = cr(2, 1) + ar(i, hs)
                     cr(2, 2) = cr(2, 2) + ar(i, rk)
                  End If
                  If ar(i, nl) < 45 And Trim(ar(i, xb)) = "女" Then
                     cr(2, 5) = cr(2, 5) + ar(i, hs)
                     cr(2, 6) = cr(2, 6) + ar(i, rk)
                  ElseIf ar(i, nl) < 45 And Trim(ar(i, xb)) = "男" Then
                     cr(2, 9) = cr(2, 9) + ar(i, hs)
                     cr(2, 10) = cr(2, 10) + ar(i, rk)
                  End If
            End If
         Next i
      End If
Next sh

With Sheets("问题二") '
'       .Range("b6:g7") = Empty '
      .[b6].Resize(2, 10) = cr '
End With '
MsgBox "ok!"
Application.ScreenUpdating = True '
End Sub

liulang0808 · 发表于 2019-10-6 13:22

楼主结合附件进一步描述下需求呗
不能删除的话，就保护工作表，对需要保护的数据所在单元格进行锁定，其他的不要锁定

xiaomaowangcai · 发表于 2019-10-6 14:10

liulang0808 发表于 2019-10-6 13:22
楼主结合附件进一步描述下需求呗
不能删除的话，就保护工作表，对需要保护的数据所在单元格进行锁定，其他 ...

就是结果显示的时候会自动清空D、E、H、I列。怎么才能让它不清空。。。。。

xiaomaowangcai · 发表于 2019-10-6 17:53

liulang0808 发表于 2019-10-6 14:36
Sub 按年龄统计()
Application.ScreenUpdating = False '
Dim ar As Variant

亲，问题一，怎么改？谢谢您，问题一和问题二类似！！！

liulang0808 · 发表于 2019-10-6 18:17

xiaomaowangcai 发表于 2019-10-6 17:53
亲，问题一，怎么改？谢谢您，问题一和问题二类似！！！

对比先后代码，只是对cr数组做了调整，还有后面的设置空区域取消了

xiaomaowangcai · 发表于 2019-10-6 18:21

liulang0808 发表于 2019-10-6 18:17
对比先后代码，只是对cr数组做了调整，还有后面的设置空区域取消了

问题一我这样改好像不对！！！ 'ReDim cr(1 To d.Count, 1 To 12) '定义一个新的动态数组，用于存放最终结果

cr = Sheets("问题一").[b7].Resize(2, 12)

xiaomaowangcai · 发表于 2019-10-6 18:22

liulang0808 发表于 2019-10-6 18:17
对比先后代码，只是对cr数组做了调整，还有后面的设置空区域取消了

Sub 按地址统计()
Application.ScreenUpdating = False '禁止屏幕刷新，提高运行速度
Dim ar As Variant '定义常量数组
Dim br() '
Dim cr() '定义动态数组
Dim i As Long '
Dim n As Long '
Dim m As Long '定义数值型变量
Dim d As Object '定义字典
Set d = CreateObject("scripting.dictionary") '建立字典控件
For Each sh In Sheets '在所有工作表中循环
      If InStr(sh.Name, "数据") > 0 Then '如果工作表名称中包含“数据”二字
         ar = sh.Range("a1").CurrentRegion ''把单元格区域赋值给数组
         If sh.Name = "数据库一" Then '
            dz = 5 '
         Else '
            dz = 7 '
         End If '以上判断地址所在列的列号
         For i = 3 To UBound(ar) '在数组的行内循环
            If Len(Trim(ar(i, dz))) <> 0 Then '如果地址列不为空
                  d(Trim(ar(i, dz))) = "" '把不重复的地址赋值给字典，作为字典关键字
            End If '结束条件判断
         Next i '结束行循环
      End If '结束工作表条件判断
Next sh '结束工作表循环

   'ReDim cr(1 To d.Count, 1 To 12) '定义一个新的动态数组，用于存放最终结果

   cr = Sheets("问题一").[b7].Resize(2, 12)  '问题二就改了这一句********* 问题一我改了，但是是错误的。。。

For Each k In d.keys '在字典关键字中循环
      n = 0 ''初始化过度数组br
      m = m + 1 '每循环一个字典关键字，则cr数组的行递增
      ReDim br(1 To 10000, 1 To 5) '定义一个新的数组作为过渡，存放临时数据


      For Each sh In Sheets '
         If InStr(sh.Name, "数据") > 0 Then '
            ar = sh.Range("a1").CurrentRegion '
            If sh.Name = "数据库一" Then '
                  dz = 5 '地址
                  hs = 2 '户数
                  xb = 3 '性别
                  rk = 4 '人口
                  nl = 7 '年龄
            Else
                  dz = 7 '
                  hs = 4 '
                  xb = 5 '
                  rk = 6 '
                  nl = 9 '
            End If '
            For i = 3 To UBound(ar) '
                  If Trim(ar(i, dz)) = k Then '
                     n = n + 1 '
                     br(n, 1) = ar(i, dz) '地址赋值给过渡数组的第一列
                     br(n, 2) = ar(i, hs) '户数赋值给过渡数组的第二列
                     br(n, 3) = ar(i, xb) '性别赋值给过渡数组的第三列
                     br(n, 4) = ar(i, rk) '人口赋值给过渡数组的第四列
                     br(n, 5) = ar(i, nl) '年龄赋值给过渡数组的第五列
                  End If '
            Next i '
         End If '
      Next sh '
      For i = 1 To n '在符合关键字条件的数组中循环
         cr(m, 1) = k '第一列等于地址
         cr(m, 2) = cr(m, 2) + br(i, 2) '计算总户数
         cr(m, 3) = cr(m, 3) + br(i, 4) '计算总人口
         If Trim(br(i, 3)) = "女" Then '如果性别列为女
            cr(m, 6) = cr(m, 6) + br(i, 2) '计算性别户数
            cr(m, 7) = cr(m, 7) + br(i, 4) '计算性别人数
         ElseIf Trim(br(i, 3)) = "男" Then '如果性别是男
            cr(m, 9) = cr(m, 9) + br(i, 2) '计算性别户数
            cr(m, 10) = cr(m, 10) + br(i, 4) '计算性别人数
         End If '
         If br(i, 5) = 50 Then '如果哪里是50岁
            cr(m, 11) = cr(m, 11) + br(i, 2) '计算50岁的户数
         End If '
         If br(i, 5) < 45 Then '如果年龄小于45岁
            cr(m, 12) = cr(m, 12) + br(i, 2) '计算45岁以下的户数
         End If '
      Next i '
Next k '结束字典关键字循环
With Sheets("问题一") '在问题一工作表中循环
      ws = .Cells(Rows.Count, 1).End(xlUp).Row + 3 '取得原来的数据的最大行的行号
      Range("a7:i" & ws).Borders.LineStyle = xlNone '取消边框

      .[a7].Resize(m, 12) = cr '把最终数组的值赋值给单元格区域
      .[a7].Resize(m, 12).Borders.LineStyle = 1 '加边框
End With '结束工作表循环
  MsgBox "ok!" ''提示框
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

liulang0808 · 发表于 2019-10-6 20:25

xiaomaowangcai 发表于 2019-10-6 18:21
问题一我这样改好像不对！！！ 'ReDim cr(1 To d.Count, 1 To 12) '定义一个新的动态数组，用于存 ...

你的cr最后赋值，导致原来有数据的区域被覆盖了，
为了不覆盖，可以先读取要被覆盖区域的数据
或者赋值的时候，逐个判断再赋值

xiaomaowangcai · 发表于 2019-10-6 21:21

liulang0808 发表于 2019-10-6 20:25
你的cr最后赋值，导致原来有数据的区域被覆盖了，
为了不覆盖，可以先读取要被覆盖区域的数据
或者赋值 ...

这个怎么改？？？？就是不太熟悉！！！！！！！！！！！！！！！！

		自动登录	找回密码
密码			免费注册

[求助] 求大神修改

评分

最新热点 /1