Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1777|回复: 4

[已解决]Excel高手用VBA第二种方法改写L列公式

[复制链接]
发表于 2016-3-28 09:34 | 显示全部楼层 |阅读模式
Excel高手用VBA第二种方法改写L列公式


最佳答案
2016-3-28 18:37
  1. Sub Macro1()
  2. Dim arr, brr, crr, i&, j&, k%
  3. arr = [c8:h23]
  4. brr = [j8:k14]
  5. ReDim crr(1 To UBound(brr), 1 To 1)
  6. For i = 1 To UBound(brr)
  7.     n = 0
  8.     For j = 1 To UBound(arr)
  9.         s1 = 0: s2 = 0
  10.         For k = 1 To UBound(arr, 2)
  11.             If arr(j, k) = brr(i, 1) Then s1 = s1 + 1
  12.             If arr(j, k) = brr(i, 2) Then s2 = s2 + 1
  13.         Next
  14.         If s1 And s2 Then n = n + 1
  15.     Next
  16.     crr(i, 1) = n
  17. Next
  18. Range("n8").Resize(UBound(crr)) = crr
  19. End Sub
复制代码

Excel高手用VBA第二种方法改写L列公式.rar

10.53 KB, 下载次数: 9

发表于 2016-3-28 18:37 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2. Dim arr, brr, crr, i&, j&, k%
  3. arr = [c8:h23]
  4. brr = [j8:k14]
  5. ReDim crr(1 To UBound(brr), 1 To 1)
  6. For i = 1 To UBound(brr)
  7.     n = 0
  8.     For j = 1 To UBound(arr)
  9.         s1 = 0: s2 = 0
  10.         For k = 1 To UBound(arr, 2)
  11.             If arr(j, k) = brr(i, 1) Then s1 = s1 + 1
  12.             If arr(j, k) = brr(i, 2) Then s2 = s2 + 1
  13.         Next
  14.         If s1 And s2 Then n = n + 1
  15.     Next
  16.     crr(i, 1) = n
  17. Next
  18. Range("n8").Resize(UBound(crr)) = crr
  19. End Sub
复制代码

评分

参与人数 1 +9 收起 理由
vbyou127 + 9 来学习

查看全部评分

回复

使用道具 举报

发表于 2016-3-28 18:54 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2016-3-28 21:28 | 显示全部楼层
爱疯 发表于 2016-3-28 18:54
http://www.excelpx.com/thread-387038-1-1.html

重复了



当然知道发相同问题了

第一种你写的,


Sub test()
    Dim A, B, i, j, k, x, y
    A = [j8:m14]
    B = Range("c8").CurrentRegion

    For k = 1 To UBound(A)
        A(k, 4) = 0
        For i = 2 To UBound(B)
            x = False
            For j = 1 To UBound(B, 2)
                If B(i, j) = A(k, 1) Then x = True: Exit For
            Next j

            y = False
            For j = 1 To UBound(B, 2)
                If B(i, j) = A(k, 2) Then y = True: Exit For
            Next j
            If x And y Then A(k, 4) = A(k, 4) + 1
        Next i
    Next k
    [m8:m14] = Application.Index(A, 0, 4)
End Sub





第二种


Sub pl()
Dim rg1 As Range: Dim i, r, n As Integer: Dim f
r = Cells(Rows.Count, "J").End(xlUp).Row
For i = 8 To r
    For Each rg In Range("C8:C23")
        Set f = rg.Resize(1, 6).Find(Cells(i, "J").Value, LookAt:=xlWhole)
        If Not f Is Nothing Then
            Set f = rg.Resize(1, 6).Find(Cells(i, "K").Value)
            If Not f Is Nothing Then n = n + 1
        End If
    Next
    Cells(i, "L").Value = n: n = 0
Next
End Sub




第三种


Sub s()
    arr = [C8:H23]
    For i = 8 To 14
        c = 0
        For j = 1 To 16
            b = Cells(i, 10)
            For k = 1 To 6
                If arr(j, k) = b Then
                    b = Cells(i, 11)
                    For l = 1 To 6
                        If arr(j, l) = b Then c = c + 1: GoTo 1
                    Next
                End If
            Next
1:
        Next
        Cells(i, 12) = c
    Next
End Sub




第四种



Function mySum(ByVal rg1 As Range, rg2 As Range) As Integer
Dim k As Integer
k = 0
For i = 1 To rg1.Rows.Count
    If Application.CountIf(rg1.Cells(1, 1).Offset(i - 1, 0).Resize(1, rg1.Columns.Count), rg2.Cells(1, 1)) _
    And Application.CountIf(rg1.Cells(1, 1).Offset(i - 1, 0).Resize(1, rg1.Columns.Count), rg2.Cells(1, 2)) Then
    k = k + 1
    End If
Next i
mySum = k
End Function


回复

使用道具 举报

 楼主| 发表于 2016-3-28 21:28 | 显示全部楼层
还有第五,六种,懒得发了
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 09:00 , Processed in 0.491118 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表