請教關於同時出現次數之統計 - Excelㄧ般區

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 106
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-5-8

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2010-6-29 06:04 | 顯示全部帖子

回復 3# 偉婕

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

學海無涯_不恥下問

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 106
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-5-8

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

3^#

發表於 2010-10-6 00:07 | 顯示全部帖子

Sub 不含對角線()
Dim Rng As Range
r = [A65536].End(xlUp).Row
For i = 2 To r
For j = i + 1 To r
If Rng Is Nothing Then
Set Rng = Cells(i, j)
Else
Set Rng = Union(Rng, Cells(i, j))
End If
Next
Next
Rng.Select
End Sub
Sub 含對角線()
Dim Rng As Range
r = [A65536].End(xlUp).Row
For i = 2 To r
For j = i To r
If Rng Is Nothing Then
Set Rng = Cells(i, j)
Else
Set Rng = Union(Rng, Cells(i, j))
End If
Next
Next
Rng.Select
End Sub

複製代碼

學海無涯_不恥下問

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 106
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-5-8

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

4^#

發表於 2010-10-8 21:12 | 顯示全部帖子

回復 8# 偉婕

Sub 對角線()
Dim Rng As Range
r = [A65536].End(xlUp).Row
For i = 2 To r
If Rng Is Nothing Then
Set Rng = Cells(i, i)
Else
Set Rng = Union(Rng, Cells(i, i))
End If
Next
Rng.Select
End Sub

複製代碼

學海無涯_不恥下問

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 106
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-5-8

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

5^#

發表於 2010-10-30 23:51 | 顯示全部帖子

回復 12# 偉婕
測試看看

Sub Ex()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
d2("單字") = "數量"
With Sheet1
For Each a In Range(.[B2], .[B65536].End(xlUp))
ar = Split(a, ";")
ReDim Preserve Ay(s)
Ay(s) = ar
s = s + 1
For Each b In ar
If b <> "" Then d(Trim(b)) = ""
Next
Next
For Each ky In d.keys
For i = 0 To UBound(Ay)
If IsNumeric(Application.Match(ky, Ay(i), 0)) Then
For Each c In Ay(i)
If c <> ky Then d1(c) = ""
Next
End If
Next
d2(ky) = d1.Count: d1.RemoveAll
Next
.[F1].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
.[G1].Resize(d2.Count, 1) = Application.Transpose(d2.items)
End With
End Sub

複製代碼

學海無涯_不恥下問

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 106
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-5-8

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

6^#

發表於 2010-10-31 22:41 | 顯示全部帖子

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

Sub Ex()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
d2("單字") = "數量"
With Sheet1
For Each a In Range(.[B2], .[B65536].End(xlUp))
ar = Split(Replace(a, "; ", ";"), ";")
ReDim Preserve Ay(s)
Ay(s) = ar
s = s + 1
For Each b In ar
If b <> "" Then d(b) = ""
Next
Next
For Each ky In d.keys
For i = 0 To UBound(Ay)
If IsNumeric(Application.Match(ky, Ay(i), 0)) Then
For Each c In Ay(i)
If c <> ky Then d1(c) = ""
Next
End If
Next
d2(ky) = d1.Count: d1.RemoveAll
Next
.[F1].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
.[G1].Resize(d2.Count, 1) = Application.Transpose(d2.items)
End With
End Sub

複製代碼

學海無涯_不恥下問