一键生成报表目录

gglili

求教老师指点，用什么代码才能一键生成报表目录

工程报表.rar (40.06 KB, 下载次数: 12)

2024-7-3 07:26 上传

点击文件名下载附件

excel玉米

这个简单，循环＋数组（或字典）就可以

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Private Sub 汇总刷新_Click()
    Application.ScreenUpdating = False
    Dim sht As Worksheet
    Set sh = ThisWorkbook.Sheets("汇总")
    arr = Intersect(sh.Columns("j:k"), sh.UsedRange)
    ReDim brr(1 To 10000, 1 To 6)
    For Each sht In ThisWorkbook.Worksheets
        If sht.Name <> "汇总" Then
            s = Application.VLookup(sht.Name, arr, 2, 0)
            If Not IsError(s) Then
                n = n + 1
                brr(n, 1) = n
                brr(n, 2) = sht.Name
                brr(n, 3) = s
                brr(n, 6) = sht.[b19]
            End If
        End If
    Next
    With sh
        .[a3:h32,f33].ClearContents
        .[a3].Resize(n, 6) = brr
        For i = 1 To n
            Sum = Sum + Val(brr(i, 6))
        Next
        .[f33] = Sum
    End With
    Beep
    Application.ScreenUpdating = True
End Sub

longwin

请看附件.....

longwin

Sub test()
Set d = CreateObject("scripting.dictionary")
arr = [j2].CurrentRegion
For i = 2 To UBound(arr)
    d(arr(i, 1)) = arr(i, 2)
Next
ReDim brr(1 To Sheets.Count - 1, 1 To 6)
hzje = 0
For Each sh In Sheets
    If sh.Name <> "汇总" Then
        m = m + 1
        brr(m, 1) = m
        brr(m, 2) = sh.Name
        brr(m, 3) = d(brr(m, 2))
        brr(m, 6) = sh.[B19].Value
        hzje = hzje + Val(brr(m, 6))
    End If
Next
[A3].Resize(m, 6) = brr
[f33] = hzje & "元"
Set d = Nothing
End Sub

roserice

不好意思，刚才发错位置了

roserice

Sub aa()
i = 2
arr = Range("j3:l" & Range("j1045576").End(xlUp).Row)

For Each a In Range("j3:l" & Range("j1045576").End(xlUp).Row)
Range("b" & i + 1) = Sheets(i).Name
s = Application.VLookup(Range("b" & i + 1), arr, 2, 0)
Range("c" & i + 1) = s
Range("f" & i + 1) = Sheets(i).Range("b19")
i = i + 1
If i = 6 Then Exit For
Next a
End Sub

LIUZHU

JS参与下

LIUZHU

搞不懂表格为什么要这样设计，“班 组 单 位 名 称”要设计成3列合并？就设计1列拉宽带点不行吗？