Board logo

標題: [發問] 請問統計字串內符合的特定條件此程式碼,可如何改善呢? [打印本頁]
作者: starry1314    時間: 2018-9-5 09:53     標題: 請問統計字串內符合的特定條件此程式碼,可如何改善呢?

本帖最後由 starry1314 於 2018-9-5 09:54 編輯

[attach]29342[/attach]

Q:目前程式碼INSTR會重複統計包含的值例(AK,K)


故想套用此公式取出所要的代號後再進行判斷

因在使用VBA呼叫內建函數會執行失敗( 不能用陣列?)  


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

請問可怎樣改寫呢??



  1. Sub 統計不屬於右側代號之數量()
  2. Dim A, xD, arr, Brr, J&, Jm&, k%
  3. Set xD = CreateObject("Scripting.Dictionary")
  4. arr = [工作表1!H1:X1]
  5. ReDim Brr(1 To 2, 1 To UBound(arr, 2))
  6. For Each A In Range([工作表1!A2], [工作表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("工作表1")
  17. .Range("G3:G4") = Brr
  18. End With
  19. End Sub
複製代碼

  1. Sub 統計右側代號之數量()

  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), 字數


  9. Set xD = CreateObject("Scripting.Dictionary")
  10. ?r?? = LenB(StrConv(Sheets("工作表1").Cells(2, i), vbFromUnicode))

  12. t(0) = Mid(Sheets("工作表1").Cells(2, i), 1, 字數 - 1)
  13. t(1) = Mid(Sheets("工作表1").Cells(2, i), 字數, 1)

  15. For Each A In Range([工作表1!A2], [工作表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("工作表1").Cells(3, i) = n(0)
  23. Sheets("工作表1").Cells(4, i) = n(1)

  25. xD.RemoveAll
  26. Erase t

  28. Erase n
  29. A = ""
  30. Next
複製代碼
作者: ikboy    時間: 2018-9-5 12:12

這裡錯了:
For Each A In Range([工作表1!A2], [工作表1!A1].Cells(Rows.Count, 1).End(xlUp)(3)).Value
For Each A In Range([工作表1!A2], [工作表1!A1].Cells(Rows.Count, 1).End(xlUp)).Value
作者: starry1314    時間: 2018-9-6 09:25

回復 2# ikboy


    感謝提醒~已修正
範例檔數量已正確~
但當我把目前所有編號都上去之後,還是又恢復一樣的情況了

像一開始說的  只有一個編號為D的   例如像在D與AD都會+1
[attach]29352[/attach]
作者: 准提部林    時間: 2018-9-6 13:31

本帖最後由 准提部林 於 2018-9-6 14:46 編輯

回復 3# starry1314

Sub 統計不屬於右側()
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    時間: 2018-9-6 16:56

本帖最後由 starry1314 於 2018-9-6 17:17 編輯

回復 4# 准提部林


想請問因編號會有重複狀況的話~此程式變成會重複計算
如何更改可讓如 10AD07C2 有10個 但只會算一個呢
  1. Sub 取不重複值()

  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
複製代碼
作者: starry1314    時間: 2018-9-6 18:20

本帖最後由 starry1314 於 2018-9-6 18:27 編輯

回復 4# 准提部林


    目前改寫為這樣
但不知怎麼調整E&f&g欄的數量...
  1. Sub 統計不屬於右側()
  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

  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

  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
複製代碼
作者: 准提部林    時間: 2018-9-6 19:33

Sub 統計不屬於右側()
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    時間: 2018-9-6 22:18

回復 7# 准提部林


    感恩,已完美解決！



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)