诸位VBA大神，求一 excel VBA 程式。输出条件下之行数据，并统计数字出现次数。

有一长串数千行数据，下面三图为简化後之范例。
问题1：在C4到I4或K4到Q4单元格内输入数字，如图1范例，在C4输入10，只搜寻相同在C列下所有10的行，然後输出每个C列有10之下一行数据，到S列。如图2所示，数据C列中搜寻到2个10，下一行数据输出到S7行，以下类推。如果在两个或以上之单元格输入数字，必须符合所有条件才输出，例如：以图1数据为例：在E4输入34，I4输入02，N4输入9，搜寻结果，在I列并没有02，所以不输出任何结果。

问题二：将输出在S列到AG列的所有数据做数字次数统计，如图三。统计分为AB数据两部分，分开统计。

问题三：如图三，分别将A与B的统计次数，数字最大的前三者，其单元格背景色用黄色标示。
P.S 可提供范例档。谢谢！

举报该问题

推荐答案 2014-10-20

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim inputRngA As Range, inputRngB As Range                    '数据输入区域
    Set inputRngA = Range("C4:I4")          'A区域
    Set inputRngB = Range("K4:Q4")          'B区域

    Dim outRngA As Range, outRngB As Range
    Set outRngA = Range("S7:Y7")
    Set outRngB = Range("AA7:AG7")
    Dim rng As Range, findRng As Range
    Dim val As Long, index2 As Long
    Dim formula As String

    formula = "SUMPRODUCT(ISBLANK($C$4:$I$4)+($C$4:$I$4=C7:I7))+SUMPRODUCT(ISBLANK($K$4:$Q$4)+($K$4:$Q$4=K7:Q7))"    '用于统计
    Dim index As Long

    If Not Application.Intersect(Target, Application.Union(inputRngA, inputRngB)) Is Nothing Then
        If Application.CountBlank(inputRngA) = 7 And Application.CountBlank(inputRngB) = 7 Then   '如果C4：I4，K4:Q4都是空，则不查找
            Exit Sub
        End If
        Application.EnableEvents = False             '防止修改修改单元格时再次发生此事件
        Range(outRngA, outRngA.End(xlDown)).Clear    '清除输出区域的内容以及格式
        Range(outRngB, outRngB.End(xlDown)).Clear    '清除输出区域的内容以及格式
        Range("AI8:AQ8,AI10:AQ10,AI12:AQ12,AI14:AQ14").ClearContents
        Range("AI8:AQ8,AI10:AQ10,AI12:AQ12,AI14:AQ14").Interior.Color = xlNone
        '复制
        For index = 3 To 13
            If Application.Evaluate(Replace(Replace(formula, "C7:I7", inputRngA.Offset(index).Address), "K7:Q7", inputRngB.Offset(index).Address)) >= 14 Then
                inputRngA.Offset(index).Copy outRngA
                Set outRngA = outRngA.Offset(1)
                inputRngB.Offset(index).Copy outRngB
                Set outRngB = outRngB.Offset(1)
            End If
        Next index

        '统计
        For index = 0 To 6 Step 2
            Set rng = Range("AI8:AQ8").Offset(index)
            rng = Application.CountIf([$S$7:$Y$17], rng.Offset(-1))
            rng.Replace What:=0, Replacement:="", LookAt:=xlWhole   '清除值是 0 的单元格
        Next index

        Set rng = Range("AS8:BA8")
        rng = Application.CountIf([$AA$7:$AG$17], rng.Offset(-1))
        rng.Replace What:=0, Replacement:="", LookAt:=xlWhole   '清除值是 0 的单元格

        '标记底色
        Set rng = Range("AI8:AQ8,AI10:AQ10,AI12:AQ12,AI14:AQ14")
        index2 = 1
        For index = 1 To 3
            val = Application.WorksheetFunction.Large(rng, index2)
            If (val = 0) Then Exit For
            Set findRng = rng.Find(What:=val, LookAt:=xlWhole)
            While Not findRng Is Nothing And findRng.Interior.Color <> 65535
                index2 = index2 + 1
                findRng.Interior.Color = 65535
                Set findRng = rng.FindNext(After:=findRng)
            Wend
        Next index
        Set rng = Range("AS8:BA8")
        index2 = 1
        For index = 1 To 3
            val = Application.WorksheetFunction.Large(rng, index2)
            If (val = 0) Then Exit For
            Set findRng = rng.Find(What:=val, LookAt:=xlWhole)
            While Not findRng Is Nothing And findRng.Interior.Color <> 65535
                index2 = index2 + 1
                findRng.Interior.Color = 65535
                Set findRng = rng.FindNext(After:=findRng)
            Wend
        Next index

        Application.EnableEvents = True               '恢复事件
    End If

End Sub

你可以下载附件，查看效果。

追问

感谢您的迅速回答！发现两个问题
1. 我的2010 office无法开启。（红色保护盾），可以改用其他储存档案吗？

2. 我用另一部电脑，开启後不知如何操作，但是看到你的范例，在C4上输入10
但是却不是显示10的下一行数据？

追答

这个是Excel 2003格式的文档， 2010的可以正常开启的。如果不能开始可能是2010的安全性设置太高。

我原来的代码是复制等于10的那一行。现在改了代码就可以了。

我重新上传了附件。附件是压缩包，里面有两个文件：一个是excel文件，你可以在C4那一行的单元格输入数据，图二图三的数据根据C4那一行的输入，自动变化。

另一个文件是文本文件，里面是VBA代码，打开你的excel工作簿，Alt+F11，打开VBE窗口，双击sheet1，然后将文本文件里的所有代码复制到右边的窗格里，你回到Excel工作表，在C4输入数据，效果就出来了。

追问

感谢你的迅速回答
我下载了你的档案後，直接就可以使用了，在C4输入数字，按enter就变化了。
不过有一个bug，可能是我题意不清，在B数据部分的处理情况与A数据的情况是相同的处理方式。目前B数据仍然显示数字所在的那行，但只要显示下一行即可。所以C4到Q4是一完整数据，符合者也是完整呈现。
无论在A或B数据上输入的数字，吻合後，显示完整的下一行，也就是从C列到Q列。
谢谢！

追答inputRngB.Offset(index).Copy outRngB
Set outRngB = outRngB.Offset(1)

改成

inputRngB.Offset(index).Offset(1).Copy outRngB
Set outRngB = outRngB.Offset(1)

追问

我照你上面的程式更改了，但是在B数据上方也就是K4到Q4输入数字，仍然显示该行，而不是下一行。A数据部分正确无误。附上图。

还有就是，如题目要求此AB数据操过七千行可以将程式设定大范围搜寻吗？目前只是用范例作为操作。

谢谢