標題: 物品分類 [打印本頁]

---

作者: sillykin    時間: 2020-8-20 23:28     標題: 物品分類

是否能依物品下去分類?

---

作者: jcchiang    時間: 2020-8-21 09:34

回復 1# sillykin

試試看
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
With Target
   If .Row = 1 And .Column = 9 Then
      Range([j2], [j2].End(4)).ClearContents
      If .Value <> "" Then
         Set a = Range([c1], [c1].End(2)).Find([I1], , , xlWhole)
         For Each b In Range(Range(a.Address), Range(a.Address).Resize(Range("a1").End(4).Row))
            If b = 1 Then d.Add b.Offset(, 2 - b.Column), ""
         Next
         [j2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
         Set d = Nothing
      Else: Exit Sub
      End If
   End If
End With
End Sub

---

作者: hcm19522    時間: 2020-8-21 10:16

https://blog.xuite.net/hcm19522/twblog/589303177

---

作者: 准提部林    時間: 2020-8-21 10:24

Sub TEST()
Dim Arr, R&, C&, T$, N&
[J2:J6000].ClearContents
T = [i1]: If T = "" Then Exit Sub
Arr = Range([F1], [B65536].End(xlUp))
For C = 2 To UBound(Arr, 2)
    If Arr(1, C) <> T Then GoTo c01
For R = 2 To UBound(Arr)
    If Val(Arr(R, C)) > 0 Then N = N + 1: Arr(N, 1) = Arr(R, 1)
Next R
c01: Next C
If N > 0 Then [j2].Resize(N) = Arr
End Sub


'=============================

---

作者: sillykin    時間: 2020-9-1 00:24

回復 4# 准提部林
感謝大大的回覆...
但還有一個小問題,是否能幫解決,如果要出現二種,是否能依選擇種類,列出物品名稱

---

作者: sillykin    時間: 2020-9-1 10:58

Sub TEST()
Dim Arr, R&, C&, T$, N&
[J2:J6000].ClearContents
T = [i1]: If T = "" Then Exit Sub
Arr = Range([F1], [B65536].End(xlUp))
For C = 2 To UBound(Arr, 2)
    If Arr(1, C) <> T Then GoTo c01
For R = 2 To UBound(Arr)
    If Val(Arr(R, C)) > 0 Then N = N + 1: Arr(N, 1) = Arr(R, 1)
Next R
c01: Next C
If N > 0 Then [j2].Resize(N) = Arr
End Sub
但試過做二個上述分別執行，方法可行，但是否能一次性執行或簡單方式呢？

---

作者: 准提部林    時間: 2020-9-1 13:54

回復 6# sillykin
Sub TEST()
Dim Arr, Brr, R&, Rn&, C&, Cn&, T$, N&
[J2:N6000].ClearContents
T = [i1]: If T = "" Then Exit Sub
Arr = Range([F1], [B65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))
For C = 2 To UBound(Arr, 2)
    If InStr("_" & T, Arr(1, C)) < 2 Then GoTo c01
    Cn = Cn + 1: Rn = 0
For R = 2 To UBound(Arr)
    If Val(Arr(R, C)) > 0 Then
       Rn = Rn + 1: Brr(Rn, Cn) = Arr(R, 1)
       If Rn > N Then N = Rn
    End If
Next R
c01: Next C
If N > 0 Then [j2].Resize(N, Cn) = Brr
End Sub


'=========================

---

作者: sillykin    時間: 2020-9-1 15:29

謝謝大大的協助
但這句語法不太懂
For C = 2 To UBound(Arr, 2)
    If InStr("_" & T, Arr(1, C)) < 2 Then GoTo c01
    Cn = Cn + 1: Rn = 0

---

作者: 准提部林    時間: 2020-9-1 16:28

回復 8# sillykin

instr 及 公式的 find 用法類似

msgbox instr("ACFT", "A") '--- =1
msgbox instr("_ACFT", "A") '--- =2
msgbox instr("_BACT", "")  '--- = 1

加 "_", 避免空字符返回1的誤判

---

作者: sillykin    時間: 2020-9-1 23:41

回復 9# 准提部林


  感謝大大的回覆...
原來還有這的用法

---

作者: Andy2483    時間: 2023-11-16 13:58

回復 7# 准提部林


    謝謝論壇,謝謝前輩指導
後學以 前輩的方案改成以不同(函數,方法,語法....等)達到相同目的,學習到很多知識
學習方案如下,請前輩再指導

Option Explicit
Sub TEST_1()
Dim Brr, Crr, C, A, i&, R&, M&, j%, U%
[J:N].ClearContents
A = Split(Replace([I1], Left([I1], 1), "_" & Left([I1], 1)), "_")
U = UBound(A): If U = -1 Then Exit Sub
Brr = Range([F1], [B65536].End(3))
ReDim Crr(1 To UBound(Brr), 1 To U)
For j = 1 To U
   C = Application.Match(A(j), [B1:H1], 0)
   If IsError(C) Then Exit Sub Else R = 1
   Crr(R, j) = Brr(1, 1) & "(" & A(j) & ")"
   For i = 1 To UBound(Brr)
      If Val(Brr(i, C)) > 0 Then
         R = R + 1
         Crr(R, j) = Brr(i, 1)
      End If
   Next
   If R > M Then M = R
Next
If M > 0 Then [J1].Resize(M, U) = Crr
End Sub

---

作者: hcm19522    時間: 2023-11-16 17:07

(輸入編號12024) google網址:https://hcm19522.blogspot.com/

---

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