[已解决]计算列内容在其它表列中出现的次数

小雨饰品

请教：如附件中的J列的公式改为VBA，即当我在'低保退保“的D列（如D5)中输入一姓名，就在“名单”表的D列中统这个姓名出现的次数并显示在J列(如）。谢谢。请不要去掉原表里面的代码，谢谢

最佳答案

月排行榜 / 总排行榜

zjdh

2013-10-26 10:14

你原来的代码有很多问题未考虑，并有错误！
修改后如下：
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a&, t%
    If Target.Column = 4 And Target.Count = 1 Then
        Application.EnableEvents = False
        W = Target.Row
        Range("A" & W & ":C" & W).ClearContents
        Range("E" & W & ":J" & W).ClearContents
        If Target = "" Then GoTo 10
        With Sheets("名单")
            For a = 3 To .Range("d65536").End(3).Row
                If .Range("d" & a) = Target.Text Then
                    t = t + 1
                    Range("a" & W) = .Range("c" & a)
                    Range("c" & W) = .Range("b" & a)
                    Range("e" & W) = .Range("e" & a)
                    Range("f" & W) = .Range("k" & a)
                    Range("h" & W) = .Range("g" & a)
                    Range("j" & W) = t
                End If
            Next a
        End With
10      Application.EnableEvents = True
    End If
End Sub

跳转到最佳答案楼层

yyyydddd8888

加了两句代码，其它代码都不用改动。
附件如下：
退保VBA提取数据计次数.zip (18.45 KB, 下载次数: 9)

2013-10-26 09:31 上传

点击文件名下载附件

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim a&, b&, str1$, str2$
   
3. If Intersect(Target, Range("d5:d300")) Is Nothing Then Exit Sub
   
4.   For a = 3 To Worksheets("名单").Range("d65536").End(3).Row
   
5.       If Worksheets("名单").Range("d" & a) = Target.Text Then
   
6.          b = b + 1
   
7.          Range("a" & Target.EntireRow.Row) = Worksheets("名单").Range("c" & a)
   
8.          Range("c" & Target.EntireRow.Row) = Worksheets("名单").Range("b" & a)
   
9.          Range("e" & Target.EntireRow.Row) = Worksheets("名单").Range("e" & a)
   
10.          Range("f" & Target.EntireRow.Row) = Worksheets("名单").Range("k" & a)
    
11.          Range("h" & Target.EntireRow.Row) = Worksheets("名单").Range("g" & a)
    
12.       End If
    
13.   Next a
    
14.          Range("j" & Target.EntireRow.Row) = b
    
15. End Sub

复制代码

zjdh

你原来的代码有很多问题未考虑，并有错误！
修改后如下：
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a&, t%
    If Target.Column = 4 And Target.Count = 1 Then
        Application.EnableEvents = False
        W = Target.Row
        Range("A" & W & ":C" & W).ClearContents
        Range("E" & W & ":J" & W).ClearContents
        If Target = "" Then GoTo 10
        With Sheets("名单")
            For a = 3 To .Range("d65536").End(3).Row
                If .Range("d" & a) = Target.Text Then
                    t = t + 1
                    Range("a" & W) = .Range("c" & a)
                    Range("c" & W) = .Range("b" & a)
                    Range("e" & W) = .Range("e" & a)
                    Range("f" & W) = .Range("k" & a)
                    Range("h" & W) = .Range("g" & a)
                    Range("j" & W) = t
                End If
            Next a
        End With
10      Application.EnableEvents = True
    End If
End Sub

小雨饰品

yyyydddd8888 发表于 2013-10-26 09:27
加了两句代码，其它代码都不用改动。
附件如下：

感谢大师的帮助。

小雨饰品

zjdh 发表于 2013-10-26 10:14
你原来的代码有很多问题未考虑，并有错误！
修改后如下：
Private Sub Worksheet_Change(ByVal Target As ...

谢谢讲师赐教和帮助。