Hsieh

回復 1# 偉婕


    是這樣的意思嗎? 990628.rar (12.71 KB)

下載次數: 35

2010-6-28 23:12

Hsieh

回復 3# 偉婕


    x是動態範圍定義名稱
因為字串資料是不斷增加
定義公式
=OFFSET(單字!$B$2,,,COUNTA(單字!$B:$B)-1,)
以B2為基準點,向下擴充B欄資料數量的列數作為範圍
因為有標題列所以COUNTA(單字!$B:$B)-1

Hsieh

1. Sub 不含對角線()
   
2. Dim Rng As Range
   
3. r = [A65536].End(xlUp).Row
   
4. For i = 2 To r
   
5.     For j = i + 1 To r
   
6.        If Rng Is Nothing Then
   
7.        Set Rng = Cells(i, j)
   
8.        Else
   
9.        Set Rng = Union(Rng, Cells(i, j))
   
10.        End If
    
11.     Next
    
12. Next
    
13. Rng.Select
    
14.      
    
15. End Sub
    
16. Sub 含對角線()
    
17. Dim Rng As Range
    
18. r = [A65536].End(xlUp).Row
    
19. For i = 2 To r
    
20.     For j = i To r
    
21.        If Rng Is Nothing Then
    
22.        Set Rng = Cells(i, j)
    
23.        Else
    
24.        Set Rng = Union(Rng, Cells(i, j))
    
25.        End If
    
26.     Next
    
27. Next
    
28. Rng.Select
    
29.      
    
30. End Sub

複製代碼

Hsieh

回復 8# 偉婕

1. Sub 對角線()
   
2. Dim Rng As Range
   
3. r = [A65536].End(xlUp).Row
   
4. For i = 2 To r
   
5.        If Rng Is Nothing Then
   
6.        Set Rng = Cells(i, i)
   
7.        Else
   
8.        Set Rng = Union(Rng, Cells(i, i))
   
9.        End If
   
10. Next
    
11. Rng.Select
    
12.      
    
13. End Sub

複製代碼

Hsieh

回復 12# 偉婕
測試看看

1. Sub Ex()
   
2. Dim Ay()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. Set d2 = CreateObject("Scripting.Dictionary")
   
6. d2("單字") = "數量"
   
7. With Sheet1
   
8. For Each a In Range(.[B2], .[B65536].End(xlUp))
   
9. ar = Split(a, ";")
   
10. ReDim Preserve Ay(s)
    
11. Ay(s) = ar
    
12. s = s + 1
    
13. For Each b In ar
    
14.   If b <> "" Then d(Trim(b)) = ""
    
15. Next
    
16. Next
    
17. For Each ky In d.keys
    
18.    For i = 0 To UBound(Ay)
    
19.       If IsNumeric(Application.Match(ky, Ay(i), 0)) Then
    
20.          For Each c In Ay(i)
    
21.            If c <> ky Then d1(c) = ""
    
22.          Next
    
23.       End If
    
24.    Next
    
25.    d2(ky) = d1.Count: d1.RemoveAll
    
26. Next
    
27. .[F1].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    
28. .[G1].Resize(d2.Count, 1) = Application.Transpose(d2.items)
    
29. End With
    
30. 
    
31. End Sub

複製代碼

Hsieh

回復 14# 偉婕
差在分號;多了空白鍵

1. Sub Ex()
   
2. Dim Ay()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. Set d2 = CreateObject("Scripting.Dictionary")
   
6. d2("單字") = "數量"
   
7. With Sheet1
   
8. For Each a In Range(.[B2], .[B65536].End(xlUp))
   
9. ar = Split(Replace(a, "; ", ";"), ";")
   
10. ReDim Preserve Ay(s)
    
11. Ay(s) = ar
    
12. s = s + 1
    
13. For Each b In ar
    
14.   If b <> "" Then d(b) = ""
    
15. Next
    
16. Next
    
17. For Each ky In d.keys
    
18.    For i = 0 To UBound(Ay)
    
19.       If IsNumeric(Application.Match(ky, Ay(i), 0)) Then
    
20.          For Each c In Ay(i)
    
21.            If c <> ky Then d1(c) = ""
    
22.          Next
    
23.       End If
    
24.    Next
    
25.    d2(ky) = d1.Count: d1.RemoveAll
    
26. Next
    
27. .[F1].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    
28. .[G1].Resize(d2.Count, 1) = Application.Transpose(d2.items)
    
29. End With
    
30. End Sub

複製代碼