VBA編程中如何利用代碼，去除合并，如圖所示情況，一些單元格資料有部分是相同的，有部分是不同的，保留合并不同的資料，把相同的資料合并為一個，放在同一個單元格里。
uj5u.com熱心網友回復：
寫了段代碼，不知道滿足不滿足需求Sub Calc()
Dim i As Integer
Dim strPre, strCur, strResult As String
Dim resultRows As Integer
strPre = Mid(Sheet1.Cells(1, 1), 2) '前一個比對內容
strResult = Mid(Sheet1.Cells(1, 1), 1, 1) & "," '結果
resultRows = 1 '結果行數
For i = 2 To Sheet1.UsedRange.Rows.Count
'把要對比的部分截取出來
strCur = Mid(Sheet1.Cells(i, 1), 2)
If strCur = strPre Then '截取部分發生重復
strResult = strResult & Mid(Sheet1.Cells(i, 1), 1, 1) & ","
Else
Sheet1.Cells(resultRows, 3) = Mid(strResult, 1, Len(strResult) - 1) + strPre '輸出結果
strResult = Mid(Sheet1.Cells(i, 1), 1, 1) & ","
resultRows = resultRows + 1
End If
If i = Sheet1.UsedRange.Rows.Count Then '剩最后一條資料時需要特殊處理一下,輸出最后一條結果
If strCur = strPre Then
Sheet1.Cells(resultRows, 3) = Mid(strResult, 1, Len(strResult) - 1) + strPre
Else
Sheet1.Cells(resultRows, 3) = Sheet1.Cells(i, 1) '輸出最后一條結果
End If
Else
strPre = strCur
End If
Next
End Sub
uj5u.com熱心網友回復：
我也寫了一個,代碼如下:
Option Explicit
Sub Compress()
Dim reg As Object
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "^(.+)系列中去除(.+)$"
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim i As Integer
i = 1
Do While Sheet1.Cells(i, 1) <> ""
Dim strCellValue As String
strCellValue = Sheet1.Cells(i, 1).Value
If reg.test(strCellValue) Then
Dim objMatch As Object
Set objMatch = reg.Execute(strCellValue)(0)
Dim strKey As String
strKey = objMatch.submatches(1)
Dim strValue As String
strValue = objMatch.submatches(0)
If dict.exists(strKey) Then
dict(strKey).Add strValue
Else
Dim col As Collection
Set col = New Collection
col.Add strValue
dict.Add strKey, col
End If
End If
i = i + 1
Loop
Sheet1.Range("C:C").Clear
i = 1
Dim varKey As Variant
For Each varKey In dict
Set col = dict(varKey)
Dim strCompress As String
strCompress = ""
Dim j As Integer
For j = 1 To col.Count
If j = col.Count Then
strCompress = strCompress & col(j)
Else
strCompress = strCompress & col(j) & ","
End If
Next
Sheet1.Cells(i, "C").Value = strCompress & "系列中去除" & varKey
i = i + 1
Next
End Sub
下載地址:
鏈接：https://pan.baidu.com/s/11cx_SH2hk3o4gH5ao65G0A
提取碼：3g6m
運行示例:
uj5u.com熱心網友回復：
Sub demo()
Dim dataArr, d, outArr, i As Long, strMid As String, strEnd As String, index As Long
dataArr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
Set d = CreateObject("scripting.dictionary")
If Not IsArray(dataArr) Then Exit Sub
strMid = Mid(dataArr(1, 1), 2, Len(dataArr(1, 1)) - 2)
For i = 1 To UBound(dataArr)
strEnd = Right(dataArr(i, 1), 1)
If d.exists(strEnd) Then
d(strEnd) = d(strEnd) & "、" & Left(dataArr(i, 1), 1)
Else
d(strEnd) = Left(dataArr(i, 1), 1)
index = index + 1
End If
Next i
ReDim outArr(1 To index, 1 To 1)
Dim keyArr, valArr
keyArr = d.keys
valArr = d.items
For i = 1 To index
outArr(i, 1) = valArr(i - 1) & strMid & keyArr(i - 1)
Next i
Range("C1:C" & index).Value = outArr
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/18444.html
標籤：VBA
上一篇：Vba求助