excelvba提取一行不重複數據?dim crrrarr = select '把選定區域賦值給arr變量,注冊到内存，今天小編就來說說關于excelvba提取一行不重複數據?下面更多詳細答案一起來看看吧!

excelvba提取一行不重複數據

dim crrr

arr = select '把選定區域賦值給arr變量,注冊到内存

Set d = CreateObject("Scripting.Dictionary") '在内存注冊第1個字典

Set d2 = CreateObject("Scripting.Dictionary") '在内存注冊第2個字典

For i = 1 To UBound(arr) '在變量arr中遍曆(走一遍)

For j = 1 To UBound(arr, 2)

sss = sss & arr(i, j)

Next

d(sss) = d(sss) 1 '把arr變量每條數據合并成一個字符串,寫入第1個字典,并計算該數據出現的次數

If d(sss) = 2 Then k = k 1: d2(sss) = k '如果次數大于1,把該字符串寫入第2個字典,并按K變量給字典編序号

sss = ""

Next

ReDim crrr(1 To d2.Count, 1 To UBound(arr, 2) 1) '重新注冊crrr變量,準備存放重複數據及次數

k = 0

For i = 1 To UBound(arr) '在變量arr中再遍曆(走一遍)

For j = 1 To UBound(arr, 2)

sss = sss & arr(i, j)

Next

If d(sss) > 1 Then '如果該字符串出現次數大于1,

For j = 1 To UBound(arr, 2)

crrr(d2(sss), j) = arr(i, j) '按第2個字典的序号把重複出現的數據給crrr變量賦值

Next

crrr(d2(sss), j) = d(sss) '按第2個字典的序号把重複出現次數給crrr變量賦值

End If

sss = ""

Next

For i = 1 To UBound(crrr, 2)

Columns(Target.Column 1).Insert 'Target代表準備放置重複數據的區域比如range("k1"),在放置區域插入crrr變更同樣大小的空列,以防止原有數據被覆蓋

Next

Target.Resize(UBound(crrr), UBound(crrr, 2)).NumberFormatLocal = "@" '把放置重複數據的區域單元格格式改為文本類型,防止超15位的數字顯示出問題

Target.Resize(UBound(crrr), UBound(crrr, 2)) = crrr '放置重複數據及重複次數

Target.Resize(UBound(crrr), UBound(crrr, 2)).NumberFormatLocal = "G/通用格式" '把放置重複數據的區域單元格格式改為常規