How to weigh?-CodePudding

VBA programming in how to use the code, remove to merge, as shown, some cell data some is the same, some are different, keep merge different data, combine the same data as a, put in the same cell,

CodePudding user response:

Write code, don't know can't satisfy meet demand

 Sub Calc () 
Dim As Integer I 
Dim strPre strCur, strResult As String 
Dim resultRows As Integer 

StrPre=Mid (Sheet1. Cells (1, 1), 2) 'previous than content 
StrResult=Mid (Sheet1. Cells (1, 1), 1, 1) & amp; ", "the results 
 'ResultRows=1 'results rows 

For I=2 To Sheet1. UsedRange. Rows. Count 
'to compare some intercept out 
StrCur=Mid (Sheet1. Cells (I, 1), 2) 

If strCur=strPre Then 'intercept part repeated 
StrResult=strResult & amp; Mid (Sheet1. Cells (I, 1), 1, 1) & amp; ", "
The Else 
Sheet1. Cells (resultRows, 3)=Mid (strResult, 1, Len (strResult) - 1) + strPre 'output 
StrResult=Mid (Sheet1. Cells (I, 1), 1, 1) & amp; ", "
ResultRows=resultRows + 1 
End the If 

If I=Sheet1. UsedRange. Rows. Count Then 'left when a data need special processing, the output end a result 
If strCur=strPre Then 
Sheet1. Cells (resultRows, 3)=Mid (strResult, 1, Len (strResult) - 1) + strPre 
The Else 
Sheet1. Cells (resultRows, 3)=Sheet1. Cells (I, 1) 'output end a result 
End the If 
The Else 
StrPre=strCur 
End the If 
Next 
End Sub

CodePudding user response:

I also wrote a, the code is as follows:

 
Option Explicit 

Sub Compress () 
Dim reg As Object 
The Set reg=CreateObject (" vbscript. Regexp ") 
Reg. The Pattern="^ (. +) to remove $" (. +) series 

Dim dict As Object 
The Set dict=CreateObject (" scripting. The dictionary ") 

Dim As Integer I 
I=1 

The Do While Sheet1. Cells (I, 1) & lt;> "
"Dim strCellValue As String 
StrCellValue=https://bbs.csdn.net/topics/Sheet1.Cells (I, 1). The Value 

The (strCellValue) Then the If reg 
Dim objMatch As Object 
The Set objMatch=reg. The Execute (strCellValue) (0) 

Dim strKey As String 
StrKey=objMatch. Submatches (1) 

Dim strValue As String 
StrValue (0)=https://bbs.csdn.net/topics/objMatch.submatches 

Then If dict. The exists (strKey) 
Dict (strKey). Add strValue 
The Else 
Dim col As Collection 
The Set col=New Collection 

Col. Add strValue 
Dict. Add strKey, col 
End the If 
End the If 

I=I + 1 
Loop 

Sheet1. Range (" C: C "). The Clear 

I=1 

Dim varKey As the Variant 
For Each varKey In dict 
The Set of 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 & amp; Col (j) 
The Else 
StrCompress=strCompress & amp; Col (j) & amp; ", "
End the If 
Next 

Sheet1. Cells (I, "C"). The Value=https://bbs.csdn.net/topics/strCompress & "remove" series & amp; VarKey 
I=I + 1 
Next 
End Sub

Download address:
Link: https://pan.baidu.com/s/11cx_SH2hk3o4gH5ao65G0A
The extracted code: 3 g6m

Run the example:

CodePudding user response:

 Sub demo () 
OutArr Dim dataArr, d, I, As Long As strMid String, strEnd As String, the index As Long 
DataArr=Range (" A1: A "& amp; Cells (Rows. The Count, 1.) the End (xlUp). Value 
 Row).The Set d=CreateObject (" scripting. The dictionary ") 
If Not IsArray (dataArr) Then the 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.e xists (strEnd) Then 
D (strEnd)=d (strEnd) & amp; ", "& amp; Left (dataArr (I, 1), 1) 
The Else 
D (strEnd)=Left (dataArr (I, 1), 1) 
The index=index + 1 
End the If 
Next I 
ReDim outArr (1 To the index, 1 To 1) 
Dim keyArr, valArr 
KeyArr=d.k eys 
ValArr=d.i tems 
For I=1 To index 
OutArr (I, 1)=valArr (I - 1) & amp; StrMid & amp; KeyArr (I - 1) 
Next I 
Range (C1: "C" & amp; The index) Value=https://bbs.csdn.net/topics/outArr 
End Sub