根据单元格内的数字，自动分配到指定的后续单元格中并用“1”显示

axichen

求教，利用VBA代码，根据单元格内的数字，自动分配到指定的后续单元格中用“1”显示并动态扩展，且在下面需要动态扩展汇总，请见附件！

newkurt

你先做第25行统计，再写上面的1，最后统计27行

不知道为什么

如图效果，供参考！

axichen

不知道为什么 发表于 2018-6-19 23:25
如图效果，供参考！

效果很好，能上传代码吗？

chaohuahch

代码如下：
Sub 自动填数()
Application.ScreenUpdating = False
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim rng As Range

Range("j3:ak1000").Clear
For i = 3 To Range("a3").End(xlDown).Row
  For j = 1 To 9
   For k = 10 To 37
    If Cells(i, j).Value = Cells(2, k).Value Then
       Cells(i, k).Value = 1
     End If
     Next
    Next
   Next

n = Range("a3").End(xlDown).Row + 3
  For k = 10 To 37
' For i = 3 To Range("a3").End(xlDown).Row

    Set rng = Range(Cells(3, k), Cells(Range("a3").End(xlDown).Row, k))

    Cells(n, k) = Application.WorksheetFunction.Sum(rng)

    Set rng = Range(Cells(Range("a3").End(xlDown).Row - 9, k), Cells(Range("a3").End(xlDown).Row, k))

    Cells(n + 2, k) = Application.WorksheetFunction.Sum(rng)
    Next

   Application.ScreenUpdating = True

End Sub

不知道为什么

不知道为什么 发表于 2018-6-19 23:25
如图效果，供参考！

不好意思，给漏发了。如图，供参考！

lsdongjh

1. Sub Test()
   
2.     Dim arr As Variant, brr As Variant, crr As Variant
   
3.     Dim lngRowID As Long, lngVal As Long
   
4.     Dim lngRows As Long, lngRow As Long, lngCol As Long
   
5.    
   
6.     lngRowID = 3 '起始行
   
7.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
8.     '数据区
   
9.     arr = Sheet1.Range("A" & lngRowID & ":I" & lngRows)
   
10.     '结果区
    
11.     Sheet1.Range("J" & lngRowID & ":AK" & lngRows) = ""
    
12.     brr = Sheet1.Range("J" & lngRowID & ":AK" & lngRows)
    
13.    
    
14.     For lngRow = 1 To UBound(arr)
    
15.         For lngCol = 1 To UBound(arr, 2)
    
16.             lngVal = arr(lngRow, lngCol)
    
17.             brr(lngRow, lngVal) = brr(lngRow, lngVal) + 1
    
18.         Next
    
19.     Next
    
20.    
    
21.     Sheet1.Range("J" & lngRowID & ":AK" & lngRows) = brr
    
22.    
    
23.     '总汇总区
    
24.     Sheet1.Range("J" & lngRows + 2 & ":AK" & lngRows + 2) = ""
    
25.     crr = Sheet1.Range("J" & lngRows + 2 & ":AK" & lngRows + 2)
    
26.    
    
27.     For lngCol = 1 To UBound(brr, 2)
    
28.         crr(1, lngCol) = Application.WorksheetFunction.Sum(Application.WorksheetFunction.Index(brr, 0, lngCol))
    
29.     Next
    
30.     Sheet1.Range("J" & lngRows + 2 & ":AK" & lngRows + 2) = crr
    
31.    
    
32.      '后10汇总区
    
33.     Sheet1.Range("J" & lngRows + 4 & ":AK" & lngRows + 4) = ""
    
34.     crr = Sheet1.Range("J" & lngRows + 2 & ":AK" & lngRows + 2)
    
35.    
    
36.     lngRowID = lngRows - 9
    
37.     brr = Sheet1.Range("J" & lngRowID & ":AK" & lngRows)
    
38.     For lngCol = 1 To UBound(brr, 2)
    
39.         crr(1, lngCol) = Application.WorksheetFunction.Sum(Application.WorksheetFunction.Index(brr, 0, lngCol))
    
40.     Next
    
41.     Sheet1.Range("J" & lngRows + 4 & ":AK" & lngRows + 4) = crr
    
42.    
    
43. End Sub
    

复制代码

axichen

chaohuahch 发表于 2018-6-20 10:55
代码如下：
Sub 自动填数()
Application.ScreenUpdating = False

非常感谢，解决了大问题。谢谢！

axichen

不知道为什么 发表于 2018-6-20 14:01
不好意思，给漏发了。如图，供参考！

用这个代码试下，谢谢楼主！

axichen

不知道为什么 发表于 2018-6-19 23:25
如图效果，供参考！

楼主，在吗？目前遇到的问题更为复杂些，需要统计的内容会更多，同时统计后需要再增加一些颜色区分内容，谢谢！