標題: [發問] 儲存格的合併問題 [打印本頁]

---

作者: pinklee    時間: 2011-7-16 08:57     標題: 儲存格的合併問題

[attach]7029[/attach]
如圖 請問不要用函數 或&,把ABC三欄的資料合併剽替定儲存格裡
A B C 不一定會有資料 因為有時不會有重複
先感謝各位先進

---

作者: dechiuan999    時間: 2011-7-17 08:22

你好：
  
   請試試如下
Sub aa()
   
    Dim mDic1 As Scripting.Dictionary
    Dim mDic2 As Scripting.Dictionary
    Dim mDic3 As Scripting.Dictionary
    Dim mRng1, mRng2, mRng3
    Dim mSht As Worksheet
    Dim mRow1%, mRow2%, mRow3%
    Dim mStr1$
    Dim s%, s1%
    Dim mData1(), mData2(), mData3()
    Dim mRng As Range
   
    Set mDic1 = CreateObject("scripting.dictionary")
    Set mDic2 = CreateObject("scripting.dictionary")
    Set mDic3 = CreateObject("scripting.dictionary")
   
   
    Set mSht = Worksheets(1)
    With mSht
        mRow1 = .[f65536].End(xlUp).Row
        mRow2 = .[h65536].End(xlUp).Row
        mRow3 = .[j65536].End(xlUp).Row
        mRng1 = .Range("f1:g" & .[f65536].End(xlUp).Row)
        mRng2 = .Range("h1:i" & .[i65536].End(xlUp).Row)
        mRng3 = .Range("j1:k" & .[j65536].End(xlUp).Row)
        
        
        For s = 1 To mRow1
            mStr1 = mRng1(s, 1)
            mDic1.Add mRng1(s, 1), ""
        Next
        
        For s = 1 To UBound(mRng1)
            mStr1 = mRng1(s, 2)
            If mDic1.Exists(mStr1) = True Then
                ReDim Preserve mData1(s1)
                mData1(s1) = mStr1 & ","
                s1 = s1 + 1
            End If
        Next
   
        .Range("a1").Resize(s1) = Application.Transpose(mData1)
        
        Set mRng = .Columns("a")
        With mRng
            .Replace ",", ""
        End With
        
        For s = 1 To mRow2
            mStr1 = mRng2(s, 1)
            mDic2.Add mRng2(s, 1), ""
        Next
        
        s1 = 0
        
        For s = 1 To UBound(mRng2)
            mStr1 = mRng2(s, 2)
            If mDic2.Exists(CInt(mStr1)) = True Then
                ReDim Preserve mData2(s1)
                mData2(s1) = mStr1 & ","
                s1 = s1 + 1
            End If
        Next
        
     
        .Range("b1").Resize(s1) = Application.Transpose(mData2)
        Set mRng = .Columns("b")
        With mRng
            .Replace ",", ""
        End With
        
        
        For s = 1 To mRow3
            mStr1 = mRng3(s, 1)
            mDic3.Add mRng3(s, 1), ""
        Next
        
        s1 = 0
        
        For s = 1 To UBound(mRng3)
            mStr1 = mRng3(s, 2)
            If mDic3.Exists(mStr1) = True Then
                ReDim Preserve mData3(s1)
                mData3(s1) = mStr1 & ","
                s1 = s1 + 1
            End If
        Next
      
        .Range("c1").Resize(s1) = Application.Transpose(mData3)
        Set mRng = .Columns("c")
        With mRng
            .Replace ",", ""
        End With
        .Range("a7") = Join(mData1) & Join(mData2) & Join(mData3)
        
    End With      
   
   
End Sub

---

作者: oobird    時間: 2011-7-17 10:15

1. Sub yy()
   
2.     Dim d As Object, i%, r%, w$, s$, t, c As Range
   
3.     [a:c] = ""
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 6 To 10 Step 2
   
6.         For Each c In Cells(1, i).Resize(6, 2).SpecialCells(2)
   
7.             w = c.Value
   
8.             d(w) = d(w) + 1
   
9.         Next
   
10.         For Each t In d
    
11.             If d(t) = 1 Then d.Remove (t)
    
12.         Next
    
13.         If d.Count > 0 Then
    
14.             r = r + 1
    
15.             Cells(1, r).Resize(d.Count, 1) = Application.Transpose(d.keys)
    
16.             If s = "" Then s = Join(d.keys, "、") Else s = s & "、" & Join(d.keys, "、")
    
17.         End If
    
18.         d.RemoveAll
    
19.     Next
    
20.     [a7] = s
    
21. End Sub

複製代碼

---

作者: pinklee    時間: 2011-7-18 19:41

謝謝！兩位高手的解答，原本只要ＡＢＣ欄合併　現在連比對都有了　且很簡潔
一個字　讚　　

---

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