Excel VBA (四) : 自訂函數之將某欄資料複製到其他位置(自動排序並濾掉重複的資料)

我有一個需求是將某欄的資料複製到其他地方, 但是希望能夠是按照大小排列, 並且過濾掉重複的資料

我先做一個測試, 如果我在A1輸入自訂函數(MyCopy), 去改變B1儲存格的內容 :

Function MyCopy() As Variant
    Cells(1, 2).Value = "AA"
    MyCopy = "OK"
End Function

結果是 #VALUE!(失敗), 再將程式修改一下, 在A1中輸入 =MyCopy(B1), 把B1當參數傳進去會怎樣

Function MyCopy(myRange As Range) As Variant
    myRange.Value = "AA"
    MyCopy = "OK"
End Function

結果依然是 #VALUE!(失敗), 只好爬文看看別人的作法, 爬了很久直到這篇文章(How to Change Another Cell with a VBA Function), 作者的技巧是用 Evaluate 函數來叫另一個自訂函數來幫忙修改其他儲存格的資料, 看來自訂函數果真無法直接修改其他儲存格的資料了!(如果有其他作法也歡迎留言告知喔), 程式再改一下測測看

Function MyCopy() As Variant
    Evaluate "MyChange(B1,100)"
    MyCopy = "OK"
End Function

Function MyChange(myRange As Range, newData As Variant)
    myRange.Value = newData
End Function

我在A1儲存格中輸入 =MyCopy(), 結果對了!!(附上圖慶祝一下)

再來是排序問題, 網路上作法很多, 最後我挑了 System.Collections.SortedList 這個物件, 程式如下 :

Function MyCopy(copyFrom As Range, copyTo As Range) As Variant
    Dim mList As Object
    Dim i As Integer
    Dim data As Variant
    
    Set mList = CreateObject("System.Collections.SortedList")   '建立排序物件
    '開始排序並且濾掉重複資料
    For Each data In copyFrom
        If data.Value <> "" Then
            '非空白的才處理
            If Not mList.ContainsKey(data.Value) Then
                mList.Add data.Value, ""  '新增
            End If
        End If
    Next

    i = 1
    '開始寫到新的位置
    For Each data In copyTo
        If i <= mList.Count Then
            '改變其他儲存格的方法
            Evaluate "MyChange(" + data.Address + ",""" + mList.GetKey(i - 1) + """)"
        Else
            Exit For
        End If
        
        i = i + 1
    Next
    
    MyCopy = "OK"
End Function

'改變其他儲存格的自訂函數
Function MyChange(myRange As Range, newData As Variant)
    myRange.Value = newData
End Function

結果還不錯, 嘗試修改A1..B6中的資料也會即時改變, 可是發現這有一個問題, 就是當我把A5的AA文字刪除後, 會變成下面畫面 :

結果會出現兩個資料D, 原因是當不重複資料總數減少時, 程式寫完結果並不會繼續清除下面之前的舊資料!! 由此可知一個真正完整不被人罵的程式要處理很多問題, 一個簡單的程式會變成很巨大, 所以我來處理這個問題看看:

Function MyCopy(copyFrom As Range, copyTo As Range) As Variant
    Dim mList As Object
    Dim i As Integer
    Dim data As Variant
    
    Set mList = CreateObject("System.Collections.SortedList")   '建立排序物件
    '開始排序並且濾掉重複資料
    For Each data In copyFrom
        If data.Value <> "" Then
            '非空白的才處理
            If Not mList.ContainsKey(data.Value) Then
                mList.Add data.Value, ""  '新增
            End If
        End If
    Next

    i = 1
    '開始寫到新的位置
    For Each data In copyTo
        If i <= mList.Count Then
            '改變其他儲存格的方法
            Evaluate "MyChange(" + data.Address + ",""" + mList.GetKey(i - 1) + """)"
        Else
            If data.Value <> "" Then
                '非空白的才處理
                Evaluate "MyChange(" + data.Address + ","""")"
            Else
                Exit For
            End If
        End If
        
        i = i + 1
    Next
    
    MyCopy = "OK"
End Function

'改變其他儲存格的自訂函數
Function MyChange(myRange As Range, newData As Variant)
    myRange.Value = newData
End Function

雖然解決了這個問題, 但是感覺處理的不是很好, 如果有好的想法歡迎留言喔! ^ ^

---

測試時間: 2020年07月30日
測試環境: Windows 10 家用版, Excel 2019 家用版