iT邦幫忙

1

EXCEL VBA 重複比對及複製刪除運用求解

小弟想寫vba程式 有點複雜完全不知道從何寫起
希望各位大大幫忙
原資料 A欄組長 B欄成員
希望能如下橫線結果刪除重複及複製接續

月珠
月珠 世祈
黃霞 清華
姵桂
士賢
士賢 秀臣
士賢 永明
士賢 筱芬

A欄組長去除重複,B欄成員能順接在本人之後,C.D.E.F...

月珠 世祈
黃霞 清華
姵桂
士賢 秀臣 永明 筱芬

之前有用過樞紐方式但不是我要的結果

slime iT邦大師 1 級 ‧ 2019-08-29 08:33:59 檢舉
個人考慮: 用陣列
1. 每列陸續讀入
2. 讀取 B 欄, 若 B 欄為空, 新增陣列, 第一個元素為 A 欄, 應用上這是組長位置.
3. 若 B 欄非空值, 比對 A 欄與陣列內的第一個元素, 若相符, 移動到陣列最後一個, 加上 B 值, 應用上這是組員位置.

4. 跑到讀入完成後, 將陣列重新列出.

(也可以產生新資料表處理)

2 個回答

1
Neish
iT邦研究生 1 級 ‧ 2019-08-29 08:38:50
最佳解答

試試看吧!
https://c-t.work/s/e10b0cf1e92b4f

應該可以滿足你的需求

註解有點難表達

Option Explicit

Sub member()

    Dim i As Integer
    Dim leader_row As Integer
    Dim member_col As Integer

    i = 2
    Do Until Range("A" & i) = ""
        
        '組長位置(如有重複會找第一個位置)
        leader_row = Columns("A").Find(Range("A" & i)).Row
        
        '組長旁邊組員的空格欄
        member_col = Rows(leader_row).Find("").Column
        
        '如果不是第一個組長位置 則把成員寫到第一個組長位置旁邊的空格
        '填上後刪除i欄 不往下找(i不加1) 因為已經刪除i欄 下欄會往上遞補 所以繼續查找i欄
        If i <> leader_row Then
            Cells(leader_row, member_col) = Range("B" & i)
            Rows(i).Delete
        '往下繼續查找
        Else
            i = i + 1
        End If
        
    Loop
    
End Sub

jasonh iT邦新手 5 級 ‧ 2019-08-30 13:12:34 檢舉

i=1

0
jasonh
iT邦新手 5 級 ‧ 2019-08-29 08:59:48

試試(結果放DE欄)
Sub 巨集1()
rA = Range("A1").End(xlDown).Row
Range("A1:A" & rA).Copy Range("D1")
ActiveSheet.Range("D1:D" & rA).RemoveDuplicates Columns:=1, Header:=xlNo
rD = Range("D1").End(xlDown).Row
c = 5
For i = 1 To rD
For j = 1 To rA
If Cells(i, "D") = Cells(j, "A") And Cells(j, "B") <> "" Then
Cells(i, c) = Cells(j, "B")
c = c + 1
End If
Next j
c = 5
Next i
End Sub

Cells(i, c) = Cells(j, "B")

可能要改成

Cells(i, c) = Cells(i, c) & Cells(j, "B")
jasonh iT邦新手 5 級 ‧ 2019-08-29 10:36:29 檢舉

如題: B欄成員能順接在本人之後,C.D.E.F...

我要發表回答

立即登入回答