VBA生成统计表

TFQWFN

VBA生成统计表

袁勇

原代码只限制了5-7行（共3行），修改行数范围吧。

TFQWFN

老师您好！能不能帮我做一下，谢谢了！

袁勇

quqiyuan

参与一下，供参考。。。

quqiyuan

参与一下，供参考。。。

limonet

关键字：##

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select '" & Sheets("清单").Range("C3") & "',#" & Sheets("清单").Range("H3") _
                & "#,F1,F3,F4,F5,F6,F7,F8 From [清单$B5:I13] Where F5>0"
    Range("B2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.26
   
2.     Dim arr, brr
   
3.     Application.ScreenUpdating = False
   
4.     Set ws = ThisWorkbook
   
5.     Set sh = ws.Sheets("统计表")
   
6.     With ws.Sheets("清单")
   
7.         arr = .UsedRange
   
8.         dw = .[c3].Value
   
9.         rq = .[h3].Value
   
10.     End With
    
11.     ReDim brr(1 To 100000, 1 To 100)
    
12.     For i = 5 To UBound(arr)
    
13.         If InStr(arr(i, 1), "金额合计") Then Exit For
    
14.         If arr(i, 2) <> Empty Then
    
15.             m = m + 1
    
16.             brr(m, 1) = m
    
17.             brr(m, 2) = dw
    
18.             brr(m, 3) = rq
    
19.             brr(m, 4) = arr(i, 2)
    
20.             For j = 4 To UBound(arr, 2)
    
21.                 brr(m, j + 1) = arr(i, j)
    
22.             Next
    
23.         End If
    
24.     Next
    
25.     With sh
    
26.         .UsedRange.Offset(1).Clear
    
27.         With .[a2].Resize(m, 10)
    
28.             .Value = brr
    
29.             .Borders.LineStyle = 1
    
30.             .HorizontalAlignment = xlCenter
    
31.             .VerticalAlignment = xlCenter
    
32.         End With
    
33.     End With
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "OK！"
    
36. End Sub
    

复制代码