每个月做数据，做到眼花，请高手帮忙写个VBA减轻工作量

烟火孤星泪

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



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

2021-10-13 20:08 上传

点击文件名下载附件

shiruiqiang

加了几句，搞定提取全部寝室的问题，第二个差不多
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

liulang0808

供参考。。。。。。

烟火孤星泪

liulang0808 发表于 2021-10-13 20:33
供参考。。。。。。

是这个效果了，谢谢

chxw68

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
    

复制代码

chxw68

简单问题。

烟火孤星泪

chxw68 发表于 2021-10-13 20:44
简单问题。

如果输出结果，输出到一个新表，修改哪里啊？谢谢！

chxw68

修改好了。

chenwenyong

这个使用PQ应该更好