麻辣家族討論版版 » Excel程式區 » 如何以vba編寫程式將A欄不順序並重覆的資料各抽一個出來順序存放於B欄

返回列表下一主題上一主題發帖

[發問] 如何以vba編寫程式將A欄不順序並重覆的資料各抽一個出來順序存放於B欄

中學生 Rank: 2

帖子: 51
主題: 14
精華: 0
積分: 143
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-11
最後登錄: 2023-5-8

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2015-9-29 16:34 | 只看該作者

[發問] 如何以vba編寫程式將A欄不順序並重覆的資料各抽一個出來順序存放於B欄

有一大堆(數以千項)重覆雜亂及不順序的資料存放於A欄，我要如何利用VBA在A欄中各抽取一個單一的資料並順序排列於B欄中？

資料結果
HK01150923-3 HK01150923-1
HK01150923-3 HK01150923-2
HK01150923-1 HK01150923-3
HK01150924-1 HK01150924-1
HK01150923-2 HK01150924-2
HK02150923-2 HK02150923-2
HK02150923-3 HK02150923-3
HK01150923-1 HK02150925-1
HK01150923-1 HK02150925-2
HK01150923-1 HK02150925-3
HK01150923-2
HK01150923-2
HK01150924-2
HK01150924-1
HK02150925-2
HK02150923-3
HK01150924-1
HK01150923-2
HK01150924-1
HK02150925-1
HK02150925-3
HK01150923-3
HK02150925-3
HK02150925-2

樓主熱帖

收藏

中學生 Rank: 2

帖子: 60
主題: 4
精華: 0
積分: 64
點名: 0
作業系統: w7-32
軟體版本: 2013.2003
閱讀權限: 20
註冊時間: 2014-11-23
最後登錄: 2016-6-6

2^#

發表於 2015-9-29 17:49 | 只看該作者

新版就使用"資料--移除重複"然後針對該欄做排序就可以
在B欄都輸入1然後用合併彙算功能也可以辦到
插入樞紐分析表也可以整理

中學生 Rank: 2

帖子: 60
主題: 4
精華: 0
積分: 64
點名: 0
作業系統: w7-32
軟體版本: 2013.2003
閱讀權限: 20
註冊時間: 2014-11-23
最後登錄: 2016-6-6

3^#

發表於 2015-9-29 18:09 | 只看該作者

本帖最後由 koo 於 2015-9-29 18:11 編輯

小的只會初淺的寫法
複製到B欄後計算超過1個就砍掉
最後請做B欄排序就可以

Sub test()
Columns("A:A").Copy Cells(1, 2)
For i = [B65536].End(xlUp).Row To 1 Step -1
Rx = Application.CountIf([B:B], Range("B" & i))
If Rx > 1 Then Cells(i, 2).Delete Shift:=xlUp
Next
End Sub

複製代碼

中學生 Rank: 2

帖子: 51
主題: 14
精華: 0
積分: 143
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-11
最後登錄: 2023-5-8

4^#

發表於 2015-9-29 19:44 | 只看該作者

我所提出的A 欄和B 欄只是方便提問，但實際上真正運作的檔案相關資料不是在A 欄，A 欄前還有很多資料。
A 欄的資料是不可删除的。不然的話會影響後逐的資料抽取。
只能將A 欄的資料提取存於B 欄待用。

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

5^#

發表於 2015-9-29 20:08 | 只看該作者

取出不重覆唯一值並排序，這是基本語法，論壇找一下有很多相關資料，
因是基本語法，不想再一直重覆作說明，儲存格參照及資料所在欄位，請自行依實際修改！

Sub TEST()
Dim Arr, AA, xD, N&
Set xD = CreateObject("Scripting.Dictionary")
For Each AA In Range([Sheet1!A1], [Sheet1!A65536].End(xlUp)).Value
　　If Mid(AA, 3, 10) Like "########-#" Then xD(AA) = ""
Next
　
N = xD.Count:　　If N = 0 Then Exit Sub
[Sheet2!A:A].ClearContents
With [Sheet2!A1].Resize(N)
　　.Value = Application.Transpose(xD.keys)
　　.Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
End With
End Sub

複製代碼

中學生 Rank: 2

帖子: 51
主題: 14
精華: 0
積分: 143
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2010-5-11
最後登錄: 2023-5-8

6^#

發表於 2015-9-29 20:47 | 只看該作者

多謝准提大大指點。
我現用的版本程式都是將資料放在另一工作紙上, 再copy and paste回資料工作紙中的正確位置。
所提的程式經改動一下，放入本人現用的程式中，己可做到一氣呵成的功能，省郤了借助先放到另一工作紙中再copy and paste回去的工序。
多謝指點。

大學生 Rank: 4

帖子: 1441
主題: 13
精華: 0
積分: 1460
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2025-10-27

熱烈參與勳章

7^#

發表於 2015-10-2 21:05 | 只看該作者

http://blog.xuite.net/hcm19522/twblog/346607668
函數參考即可

靜思自在 : 做該做的事是智慧，做不該做的事是愚癡。

返回列表下一主題上一主題