符合指定條件.並合併傳回相對應儲存格內容.

joey3277

下載 (56.4 KB)

2013-11-21 11:14

如上圖
如果相對應的A欄  有不同的內容與重覆相同的
有哪各公式可自動清除重覆 並合併不同內容再同一各儲存格

luhpro

回復 1# joey3277
這用 Excel VBA 較容易寫 :

1. Sub nn()
   
2.   Dim lSou&, lTar&
   
3.   Dim sStr$
   
4.   Dim vD, vK, vI
   
5.   
   
6.   Set vD = CreateObject("Scripting.Dictionary")
   
7.   lSou = 2
   
8.   
   
9.   Do While Cells(lSou, 3) <> ""
   
10.     sStr = CStr(Cells(lSou, 1))
    
11.     If InStr(1, vD(CStr(Cells(lSou, 3))), sStr) = 0 Then
    
12.       If vD(CStr(Cells(lSou, 3))) = "" Then
    
13.         vD(CStr(Cells(lSou, 3))) = sStr
    
14.       Else
    
15.         vD(CStr(Cells(lSou, 3))) = vD(CStr(Cells(lSou, 3))) & "&" & sStr
    
16.       End If
    
17.     End If
    
18.     lSou = lSou + 1
    
19.   Loop
    
20.   
    
21.   lSou = 0
    
22.   lTar = 2
    
23.   vK = vD.keys
    
24.   vI = vD.items
    
25.   Do While lSou < vD.Count
    
26.     Cells(lTar, 5) = vI(lSou)
    
27.     Cells(lTar, 6) = vK(lSou)
    
28.     lTar = lTar + 1
    
29.     lSou = lSou + 1
    
30.   Loop
    
31. End Sub

複製代碼

joey3277

感謝大大的回覆  
又想請問
1.我求的結果顯示在  跟   資料在不同的檔案的話   要如何修改  
如資料在A檔案   但你提供的巨集篩選想顯示在B檔案
2.如果我的訂單月份欄輸入的方式改成數字後面加一各小數點.如(1.)
這樣用公式的方式合併A欄的資料時也分的清楚.如(1.2.).
但想請問不用巨集的方式
公式要如何寫

luhpro

感謝大大的回覆  
又想請問
1.我求的結果顯示在  跟   資料在不同的檔案的話   要如何修改  
如資料在A檔 ...
joey3277 發表於 2013-11-29 10:41

剛剛看到程式可以再做簡化,
只要在開頭加上 Dim rTar As Range
再於第一個 Do 底下加 Set rTar = .Cells(lSou, 3)
就可以把其下的 .Cells(lSou, 3) 用 rTar 取代.

1.

1. Sub nn()
   
2.   Dim lSou&, lTar&
   
3.   Dim sStr$
   
4.   Dim rTar As Range
   
5.   Dim vD, vK, vI
   
6.   
   
7.   Set vD = CreateObject("Scripting.Dictionary")
   
8.   With Workbooks.Open(ThisWorkbook.Path & "\資料.xls").Sheets("Sheet1")
   
9.     lSou = 2
   
10.   
    
11.     Do While .Cells(lSou, 3) <> ""
    
12.       Set rTar = .Cells(lSou, 3)
    
13.       sStr = CStr(.Cells(lSou, 1))
    
14.       If InStr(1, vD(CStr(rTar)), sStr) = 0 Then
    
15.         If vD(CStr(rTar)) = "" Then
    
16.           vD(CStr(rTar)) = sStr
    
17.         Else
    
18.           vD(CStr(rTar)) = vD(CStr(rTar)) & "&" & sStr
    
19.         End If
    
20.       End If
    
21.       lSou = lSou + 1
    
22.     Loop
    
23.   End With
    
24.   
    
25.   lSou = 0
    
26.   lTar = 2
    
27.   vK = vD.keys
    
28.   vI = vD.items
    
29.   Do While lSou < vD.Count
    
30.     Cells(lTar, 1) = vI(lSou)
    
31.     Cells(lTar, 2) = vK(lSou)
    
32.     lTar = lTar + 1
    
33.     lSou = lSou + 1
    
34.   Loop
    
35. End Sub

複製代碼

2. 將 vD(CStr(rTar)) = vD(CStr(rTar)) & "&" & sStr 中的 "&" 改為 "."

3. 這就要用到 Excel VBA 實作 自訂工作表函數 了:
以下程式放在 Module 內

1. Function GetData(rIVar As Range, rTar As Range, iInd As Integer) As String
   
2.   ' rIVar 要篩選的值所在儲存格, rTar 清單中篩選欄首格, iInd 資料欄與篩選欄的欄數差
   
3.   Dim lRows&
   
4.   Dim sStr$
   
5.   Dim rRng
   
6.   Dim vD, vK, vI
   
7. 
   
8.   Application.Volatile ' 設為揮發性函數(每次相關儲存格有異動都要重新計算)
   
9.   Set vD = CreateObject("Scripting.Dictionary")
   
10.   lRows = rTar.End(xlDown).Row - rTar.Row
    
11.   Set rTar = Range(rTar, rTar.Offset(lRows))
    
12.   For Each rRng In rTar
    
13.     sStr = CStr(rRng.Offset(, iInd))
    
14.     If InStr(1, vD(CStr(rRng)), sStr) = 0 Then
    
15.       If vD(CStr(rRng)) = "" Then
    
16.         vD(CStr(rRng)) = sStr
    
17.       Else
    
18.         vD(CStr(rRng)) = vD(CStr(rRng)) & "&" & sStr
    
19.       End If
    
20.     End If
    
21.   Next
    
22.   
    
23.   lRows = 0
    
24.   vK = vD.keys
    
25.   vI = vD.items
    
26.   Do While lRows < vD.Count
    
27.     If vK(lRows) = rIVar.Text Then GetData = vI(lRows)
    
28.     lRows = lRows + 1
    
29.   Loop
    
30. End Function
    
31. 
    
32. Function NrSmall(rTar As Range, iI As Integer) As Integer
    
33.   Dim vD
    
34.   Dim rRng As Range
    
35.   Dim aDat()
    
36. 
    
37.   Application.Volatile ' 設為揮發性函數(每次相關儲存格有異動都要重新計算)
    
38.   Set rTar = Range([c2], [c9])
    
39.   Set vD = CreateObject("Scripting.Dictionary")
    
40.   ReDim aDat(0)
    
41.   For Each rRng In rTar
    
42.     If vD(CStr(rRng)) = "" Then
    
43.       If aDat(0) <> 0 Then ReDim Preserve aDat(UBound(aDat) + 1)
    
44.       aDat(UBound(aDat)) = rRng
    
45.       vD(CStr(rRng)) = rRng
    
46.     End If
    
47.   Next
    
48.   NrSmall = Application.Small(aDat, iI)
    
49. End Function

複製代碼

E2==GetData(F2,C$2,-2) (其下儲存格公式沿用)
F2==NrSmall(C$2:C$9,ROW()-1)  (其下儲存格公式沿用)