[µo°Ý] ½Ð°Ý²Î­p¦r¦ê¤º²Å¦Xªº¯S©w±ø¥ó¦¹µ{¦¡½X,¥i¦p¦ó§ïµ½©O?

starry1314

½Ð±Ð½d¨Ò.rar (19.2 KB)

¤U¸ü¦¸¼Æ: 6

2018-9-5 09:48

Q:¥Ø«eµ{¦¡½XINSTR·|­«½Æ²Î­p¥]§tªº­È¨Ò(AK,K)

¬G·Q®M¥Î¦¹¤½¦¡¨ú¥X©Ò­nªº¥N¸¹«á¦A¶i¦æ§PÂ_

¦]¦b¨Ï¥ÎVBA©I¥s¤º«Ø¨ç¼Æ·|°õ¦æ¥¢±Ñ( ¤£¯à¥Î°}¦C?)  

If Application.WorksheetFunction.Mid(A, 3,Match(, 0 * Mid(A, {4, 5, 6, 7, 8, 9}, 1), 1)) = arr(1, J) Then Jm = J:Exit For

½Ð°Ý¥i«ç¼Ë§ï¼g©O??

1. Sub ²Î­p¤£ÄÝ©ó¥k°¼¥N¸¹¤§¼Æ¶q()
   
2. Dim A, xD, arr, Brr, J&, Jm&, k%
   
3. Set xD = CreateObject("Scripting.Dictionary")
   
4. arr = [¤u§@ªí1!H1:X1]
   
5. ReDim Brr(1 To 2, 1 To UBound(arr, 2))
   
6. For Each A In Range([¤u§@ªí1!A2], [¤u§@ªí1!A1].Cells(Rows.Count, 1).End(xlUp)(3)).Value
   
7.     If A = "0" Or xD(A) = 1 Then GoTo 101
   
8.     Jm = 1
   
9.     For J = 1 To UBound(arr, 2) ' Step 2
   
10.         If InStr(A, arr(1, J)) Then Jm = J: Exit For
    
11.     Next J
    
12.     If InStr(A, "V") Then k = 2 Else k = 1
    
13.     Brr(k, Jm) = Brr(k, Jm) + 1
    
14.     xD(A) = 1
    
15. 101: Next
    
16. With Sheets("¤u§@ªí1")
    
17. .Range("G3:G4") = Brr
    
18. End With
    
19. End Sub

½Æ»s¥N½X

1. Sub ²Î­p¥k°¼¥N¸¹¤§¼Æ¶q()
   
2. 
   
3. Dim i
   
4. For i = 8 To 25 'Cells(3, ActiveSheet.Columns.Count).End(xlToLeft).Column  '18 '????
   
5. 'Cells(5, ActiveSheet.Columns.Count).End(xlToLeft).Column 1
   
6. Dim A, xD, t$(1), n&(1), ¦r¼Æ
   
7. 
   
8. 
   
9. Set xD = CreateObject("Scripting.Dictionary")
   
10. ?r?? = LenB(StrConv(Sheets("¤u§@ªí1").Cells(2, i), vbFromUnicode))
    
11. 
    
12. t(0) = Mid(Sheets("¤u§@ªí1").Cells(2, i), 1, ¦r¼Æ - 1)
    
13. t(1) = Mid(Sheets("¤u§@ªí1").Cells(2, i), ¦r¼Æ, 1)
    
14. 
    
15. For Each A In Range([¤u§@ªí1!A2], [¤u§@ªí1!A1].Cells(Rows.Count, 1).End(xlUp)(3)).Value
    
16.     If A = "0" Or xD(A) = 1 Then GoTo 101
    
17.     If InStr(A, t(0)) Then
    
18.         If InStr(A, t(1)) Then n(1) = n(1) + 1 Else n(0) = n(0) + 1
    
19.     End If
    
20.     xD(A) = 1
    
21. 101: Next
    
22. Sheets("¤u§@ªí1").Cells(3, i) = n(0)
    
23. Sheets("¤u§@ªí1").Cells(4, i) = n(1)
    
24. 
    
25. xD.RemoveAll
    
26. Erase t
    
27. 
    
28. Erase n
    
29. A = ""
    
30. Next

½Æ»s¥N½X

ikboy

³o¸Ì¿ù¤F:
For Each A In Range([¤u§@ªí1!A2], [¤u§@ªí1!A1].Cells(Rows.Count, 1).End(xlUp)(3)).Value
For Each A In Range([¤u§@ªí1!A2], [¤u§@ªí1!A1].Cells(Rows.Count, 1).End(xlUp)).Value

starry1314

¦^´_ 2# ikboy


    ·PÁ´£¿ô~¤w­×¥¿
½d¨ÒÀɼƶq¤w¥¿½T~
¦ý·í§Ú§â¥Ø«e©Ò¦³½s¸¹³£¤W¥h¤§«á,ÁÙ¬O¤S«ì´_¤@¼Ëªº±¡ªp¤F

¹³¤@¶}©l»¡ªº  ¥u¦³¤@­Ó½s¸¹¬°Dªº   ¨Ò¦p¹³¦bD»PAD³£·|+1
½Ð±Ð½d¨Ò-1.rar (37.67 KB)

¤U¸ü¦¸¼Æ: 8

2018-9-6 09:24

­ã´£³¡ªL

¦^´_ 3# starry1314

Sub ²Î­p¤£ÄÝ©ó¥k°¼()
Dim A, xD, Arr, j&, Jm%, k%, T$
Set xD = CreateObject("Scripting.Dictionary")
Arr = [F1:Y2]
For j = 1 To UBound(Arr, 2)
    xD(Arr(1, j)) = j: Arr(1, j) = "": Arr(2, j) = ""
Next j

For Each A In Range([A2], [A1].Cells(Rows.Count, 1).End(xlUp)).Value
    T = Mid(A, 3): If T = "" Then GoTo 101
    For j = 1 To Len(T)
        If Val(Mid(T, j, 1) & 1) Then T = Left(T, j - 1): Exit For
    Next
    k = 1: If Right(A, 1) = "V" Then k = 2
    Jm = xD(T)
    If Jm = 0 Then Arr(k, 1) = Val(Arr(k, 1)) + 1: GoTo 101
    Arr(k, Jm) = Val(Arr(k, Jm)) + 1
    Arr(k, 2) = Val(Arr(k, 2)) + 1
101: Next
[F3].Resize(2, UBound(Arr, 2)) = Arr
End Sub

starry1314

¦^´_ 4# ­ã´£³¡ªL


·Q½Ð°Ý¦]½s¸¹·|¦³­«½Æª¬ªpªº¸Ü~¦¹µ{¦¡Åܦ¨·|­«½Æ­pºâ
¦p¦ó§ó§ï¥iÅý¦p 10AD07C2 ¦³10­Ó ¦ý¥u·|ºâ¤@­Ó©O

1. Sub ¨ú¤£­«½Æ­È()
   
2. 
   
3. Dim d As Object
   
4. Dim lRow As Long
   
5. Dim i As Long
   
6. Dim str As Variant
   
7. Dim strKey As String
   
8. Set d = CreateObject("scripting.dictionary")
   
9. lRow = Range("A65536").End(xlUp).Row
   
10. str = Range("A1:A" & lRow + 1)
    
11. For i = 1 To lRow
    
12.     strKey = str(i, 1)
    
13.     If strKey <> "" Then d(strKey) = ""
    
14. Next i
    
15. If d.Count Then [B1].Resize(d.Count) = Application.Transpose(d.keys)
    
16. End Sub

½Æ»s¥N½X

starry1314

¦^´_ 4# ­ã´£³¡ªL


    ¥Ø«e§ï¼g¬°³o¼Ë
¦ý¤£ª¾«ç»ò½Õ¾ãE&f&gÄ檺¼Æ¶q...

1. Sub ²Î­p¤£ÄÝ©ó¥k°¼()
   
2. Set xD = CreateObject("Scripting.Dictionary")
   
3. Set xC = CreateObject("Scripting.Dictionary")
   
4. Arr = [F1:Y2]
   
5. For j = 1 To UBound(Arr, 2)
   
6.     xD(Arr(1, j)) = j: Arr(1, j) = "": Arr(2, j) = ""
   
7. Next j
   
8. 
   
9. For Each A In Range([A2], [A1].Cells(Rows.Count, 1).End(xlUp)).Value
   
10.     T = Mid(A, 3): If T = "" Then GoTo 101
    
11.     For j = 1 To Len(T)
    
12.         If Val(Mid(T, j, 1) & 1) Then T = Left(T, j - 1): Exit For
    
13.     Next
    
14.     k = 1: If Right(A, 1) = "V" Then k = 2
    
15.     Jm = xD(T)
    
16.     If A = "0" Or xC(A) = 1 Then GoTo 102
    
17. 
    
18.    '
    
19.     If Jm = 0 Then Arr(k, 1) = Val(Arr(k, 1)) + 1: GoTo 101
    
20.     Arr(k, Jm) = Val(Arr(k, Jm)) + 1
    
21.     Arr(k, 2) = Val(Arr(k, 2)) + 1
    
22. 102:
    
23.         xC(A) = 1
    
24. 101: Next
    
25. [f3].Resize(2, UBound(Arr, 2)) = Arr
    
26. End Sub

½Æ»s¥N½X

­ã´£³¡ªL

Sub ²Î­p¤£ÄÝ©ó¥k°¼()
Dim A, xD, Arr, j&, Jm%, k%, T$
Set xD = CreateObject("Scripting.Dictionary")
Arr = [F1:Y2]
For j = 1 To UBound(Arr, 2)
    xD(Arr(1, j)) = j: Arr(1, j) = "": Arr(2, j) = ""
Next j

For Each A In Range([A2], [A1].Cells(Rows.Count, 1).End(xlUp)).Value
    T = Mid(A, 3): If T = "" Or xD(A) = 1 Then GoTo 101
    xD(A) = 1
    For j = 1 To Len(T)
        If Val(Mid(T, j, 1) & 1) Then T = Left(T, j - 1): Exit For
    Next
    k = 1: If Right(A, 1) = "V" Then k = 2
    Jm = xD(T)
    If Jm = 0 Then Arr(k, 1) = Val(Arr(k, 1)) + 1: GoTo 101
    Arr(k, Jm) = Val(Arr(k, Jm)) + 1
    Arr(k, 2) = Val(Arr(k, 2)) + 1
101: Next
[F3].Resize(2, UBound(Arr, 2)) = Arr
End Sub

starry1314

¦^´_ 7# ­ã´£³¡ªL


    ·P®¦,¤w§¹¬ü¸Ñ¨M¡I