ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
数据管理利器Foxtable2022下载 Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 Power Query数据清洗实战攻略 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 205|回复: 8

[已解决] 每个月做数据,做到眼花,请高手帮忙写个VBA减轻工作量

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-10-13 20:09 | 显示全部楼层 |阅读模式

根据红色方框的内容,提出蓝色方框的效果。请大神们帮一下忙,谢谢!!

image.png

9月份班级学生宿舍管理量化汇总111111 - 副本.zip (33.42 KB, 下载次数: 4)


QQ图片20211013201142.png




TA的精华主题

TA的得分主题

发表于 2021-10-13 20:30 | 显示全部楼层
加了几句,搞定提取全部寝室的问题,第二个差不多
Private Sub CommandButton4_Click()
Application.ScreenUpdating = False
    Dim arr, i&, r&, d As Object
    Set d = CreateObject("scripting.dictionary")
    With Sheets("内务")
        r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算工作表最后一个非空行号
        arr = .Range("A5:c" & r)     '区域修改   A2:c
        For i = 2 To UBound(arr)
        If arr(i, 1) = "" Then
         arr(i, 1) = arr(i - 1, 1)
            If Not d.exists(arr(i, 1)) Then
                d(arr(i, 1)) = arr(i, 3)      '选择列修改arr(i, 3),的3
            Else
                d(arr(i, 1)) = d(arr(i, 1)) & "、" & arr(i, 3)   '选择列修改arr(i, 3),的3
            End If
          End If
        Next
    End With
    With Sheets("内务")
       ' .UsedRange.Offset(1).ClearContents
      Range("ai6:ak5000").ClearContents

        .[ai6].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
        .[aj6].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
    End With
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub

TA的精华主题

TA的得分主题

发表于 2021-10-13 20:33 | 显示全部楼层
供参考。。。。。。

9月份班级学生宿舍管理量化汇总111111 - 副本.zip

33.68 KB, 下载次数: 12

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-10-13 20:38 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-10-13 20:43 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   With Worksheets("内务")
  5.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
  6.     arr = .Range("a6:ae" & r)
  7.     ReDim brr(1 To UBound(arr), 1 To 3)
  8.     m = 0
  9.     For i = 1 To UBound(arr)
  10.       If Len(arr(i, 1)) <> 0 Then
  11.         m = m + 1
  12.         brr(m, 1) = arr(i, 1)
  13.       End If
  14.       brr(m, 2) = brr(m, 2) & "、" & arr(i, 3)
  15.       If arr(i, 28) = 20 Then
  16.         brr(m, 3) = brr(m, 3) & "、" & arr(i, 3)
  17.       End If
  18.     Next
  19.     For i = 1 To m
  20.       For j = 2 To 3
  21.         If Len(brr(i, j)) <> 0 Then
  22.           brr(i, j) = Mid(brr(i, j), 2)
  23.         End If
  24.       Next
  25.     Next
  26.     .Range("ai6:ak" & .Rows.Count).ClearContents
  27.     .Range("ai6").Resize(m, UBound(brr, 2)) = brr
  28.   End With
  29. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2021-10-13 20:44 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-10-13 21:10 | 显示全部楼层

如果输出结果,输出到一个新表,修改哪里啊?谢谢!

TA的精华主题

TA的得分主题

发表于 2021-10-13 21:57 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-10-13 22:13 来自手机 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2021-10-25 05:25 , Processed in 0.065603 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表