Board logo

標題: 符合指定條件.並合併傳回相對應儲存格內容. [打印本頁]
作者: joey3277    時間: 2013-11-21 11:17     標題: 符合指定條件.並合併傳回相對應儲存格內容.

[attach]16813[/attach]
如上圖
如果相對應的A欄  有不同的內容與重覆相同的
有哪各公式可自動清除重覆 並合併不同內容再同一各儲存格
作者: luhpro    時間: 2013-11-24 11:29

回復 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    時間: 2013-11-29 10:41

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

本帖最後由 luhpro 於 2013-11-30 10:35 編輯
感謝大大的回覆  
又想請問
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

  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

  32. Function NrSmall(rTar As Range, iI As Integer) As Integer
  33.   Dim vD
  34.   Dim rRng As Range
  35.   Dim aDat()

  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)  (其下儲存格公式沿用)



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)