求助各位大佬，想了五天了没想出来

各位大佬，表格里面很多数据是这样不按照顺序出现，每一个数据都是'A[lbk]数字[rbk]' ，每一行数据量还不完全相同，想重新编排，怎么才能实现，自动按照出现顺序编号。
具体大概是图一是之前的，想变成图二的。

看不懂可能我语文不过关

海州区美度网络科技工作..

办公软件excel2016，电脑版安装激活，包含2021/2019/2016/2013/2010等多个版本，密钥激活安装，永久使用

2025-02-04 05:04广告

立即查看

按照每个格子内第一组出现的数字，对列进行升序排序？
6006为什么变成了2470？

啊，我貌似懂了，是按照第一个出现的编号，按着顺序往后排是吗？
然后保证与原表的格式、原表的编号数量一样，生成一组顺序的编码。

是不是你要的？？？？我猜的

Sub 问题()
Dim reg, sols, a, b, c, d, r
Dim minv, minv2 As Long
Dim st As String
r = [a1].End(xlDown).row
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "\d+"
arr = [a1].CurrentRegion
For a = 1 To r
Set sols = reg.Execute(arr(a, 1))
For b = 0 To sols.Count - 1
st = st & "," & sols(b)
Next
Next
brr = Split(st, ",")
For a = 1 To UBound(brr, 1)
minv = brr(a)
minv2 = brr(a)
For b = a + 1 To UBound(brr, 1)
If brr(b) < minv Then
minv = brr(b)
r = b
End If
Next
If minv < brr(a) Then
brr(a) = brr(r)
brr(r) = minv2
End If
Next
c = 1
For a = 1 To UBound(arr, 1)
Set sols = reg.Execute(arr(a, 1))
crr = Split(arr(a, 1), ",")
If UBound(crr, 1) > 0 Then
b = 0
For d = 0 To UBound(crr, 1)
crr(d) = Replace(crr(d), sols(b), brr(c))
b = b + 1
c = c + 1
Next
arr(a, 1) = Join(crr, ",")
Else
For b = 0 To sols.Count - 1
arr(a, 1) = Replace(arr(a, 1), sols(b), brr(c))
c = c + 1
Next
End If
Next
[c1].Resize(UBound(arr, 1), 1) = arr
Set reg = Nothing
Set sols = Nothing
End Sub

谢谢各位大佬支持，之前描述不太清楚，重新描述了问题

自定义排序

Sub 企鹅47436528()
Dim 最小值 As Double, brr
Set d = CreateObject("scripting.dictionary")
Set reg = CreateObject("VbScript.regexp") '创建正则项目方法
arr = UsedRange
With reg
.Global = True '匹配次数为多次
.Pattern = "\d+" '定义正则表达式规则
For i = 1 To UBound(arr)
s = arr(i, 1)
If Not .test(s) Then GoTo linenext
Set cy = .Execute(s) '返回一个对象，该对象包含每个匹配成功的match对象,一维数组
For n = 0 To cy.Count - 1
If 最小值 = 0 Then 最小值 = cy(n)
If cy(n) < 最小值 Then 最小值 = cy(n)
Next n
d(CDbl(cy(0))) = Array(CDbl(cy(0)), cy.Count)
linenext:
Next i
End With
'排序（以首个数字进行排序）
p = d.items
For i = 0 To UBound(p) - 1
For n = i + 1 To UBound(p)
If p(i)(0) > p(n)(0) Then
暂存 = p(i)
p(i) = p(n)
p(n) = 暂存
End If
Next n
Next i
'赋值
ReDim brr(UBound(p))
For i = 0 To UBound(p)
For n = 1 To p(i)(1)
brr(i) = IIf(brr(i) = "", "A[" & 最小值 & "]", brr(i) & ",A[" & 最小值 & "]")
最小值 = 最小值 + 1
Next n
Next i
[c1].Resize(UBound(brr)) = Application.Transpose(brr) '输出结果
End Sub

Sub 问题()
Dim reg, sols, a, b, c, d, r
r = [a1].End(xlDown).row
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "\d+"
arr = [a1].CurrentRegion
Set sols = reg.Execute(arr(1, 1))
c = sols(0)
b = 0
For a = 1 To UBound(arr, 1)
Set sols = reg.Execute(arr(a, 1))
crr = Split(arr(a, 1), ",")
If UBound(crr, 1) > 0 Then
For d = 0 To UBound(crr, 1)
crr(d) = Replace(crr(d), sols(b), c)
b = b + 1
c = c + 1
Next
arr(a, 1) = Join(crr, ",")
Else
For b = 0 To sols.Count - 1
arr(a, 1) = Replace(arr(a, 1), sols(b), c)
c = c + 1
Next
End If
b = 0
Next
[c1].Resize(UBound(arr, 1), 1) = arr
Set reg = Nothing
Set sols = Nothing
End Sub

先定距拆分单元格，再排序。然后再合并，

无脑堆一个

楼上大佬的宏已经能基本解决问题了，在实际使用还遇到几个问题；目前我想用宏写个循环查找替换，但是不怎么会写，一直报错

，有朋友能帮忙debug如何实现循环查找编号替换吗？

Sub 企鹅47436528()
Dim 最小值 As Double, brr, k
Set d = CreateObject("scripting.dictionary")
Set reg = CreateObject("VbScript.regexp") '创建正则项目方法
arr = UsedRange
With reg
.Global = True '匹配次数为多次
.Pattern = "\[\d+" '定义正则表达式规则
For i = 1 To UBound(arr)
s = arr(i, 1)
If s = "" Then GoTo linenext
Set cy = .Execute(s)
ReDim k(cy.Count): k(0) = s
For n = 0 To cy.Count - 1
ss = Replace(cy(n), "[", "")
If 最小值 = 0 Then 最小值 = ss
k(n + 1) = CDbl(ss)
Next n
d(s) = k
linenext:
Next i
End With
'排序（以首个数字进行排序）
p = d.items
For i = 0 To UBound(p) - 1
If UBound(p(i)) = 0 Then GoTo line1
For n = i + 1 To UBound(p)
If p(i)(1) > p(n)(1) Then
暂存 = p(i)
p(i) = p(n)
p(n) = 暂存
End If
Next n
line1:
Next i
'赋值
ReDim brr(UBound(p))
For i = 0 To UBound(p)
If UBound(p(i)) > 0 Then
For n = 1 To UBound(p(i))
p(i)(0) = Replace(p(i)(0), p(i)(n), 最小值)
最小值 = 最小值 + 1
Next n
End If
brr(i) = p(i)(0)
Next i
[c1].Resize(UBound(brr) + 1) = Application.Transpose(brr) '输出结果
End Sub

Sub 问题()
Dim reg, sols, a, b, c, d, r, av
r = Cells(Rows.Count, 1).End(xlUp).row
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "\d+"
arr = Range("A1:A" & r)
For a = 1 To r
If arr(a, 1) Like "*A[[]*" Then
Set sols = reg.Execute(arr(a, 1))
c = sols(0)
av = a
Exit For
End If
Next
b = 0
For a = av To r
If arr(a, 1) Like "*A[[]*" Then
Set sols = reg.Execute(arr(a, 1))
crr = Split(arr(a, 1), ",")
If UBound(crr, 1) > 0 Then
For d = 0 To UBound(crr, 1)
crr(d) = Replace(crr(d), sols(b), c)
b = b + 1
c = c + 1
Next
arr(a, 1) = Join(crr, ",")
Else
arr(a, 1) = Replace(arr(a, 1), sols(0), c)
c = c + 1
End If
End If
b = 0
Next
[c1].Resize(UBound(arr, 1), 1) = arr
Set reg = Nothing
Set sols = Nothing
End Sub

还有条件吗？？？所以你的需求在你发第一贴的时候就不对，本来很简单的一件事情，你的数据都贴不完全，数据提取的要求给不出来，不断地累积，到最后是不是要重新更换代码

Sub 问题()
Dim reg, sols, a, b, c, d, r, av
r = Cells(Rows.Count, 1).End(xlUp).row
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "\d+"
arr = Range("A1:A" & r)
For a = 1 To r
If arr(a, 1) Like "*A[[]*" Then
Set sols = reg.Execute(arr(a, 1))
c = sols(0)
av = a
Exit For
End If
Next
b = 0
For a = av To r
If arr(a, 1) Like "*A[[]*" Then
Set sols = reg.Execute(arr(a, 1))
crr = Split(arr(a, 1), ",")
If UBound(crr, 1) > 0 Then
For d = 0 To UBound(crr, 1)
If crr(d) <> "" Then
crr(d) = Replace(crr(d), sols(b), c)
b = b + 1
c = c + 1
End If
Next
arr(a, 1) = Join(crr, ",")
Else
arr(a, 1) = Replace(arr(a, 1), sols(0), c)
c = c + 1
End If
End If
b = 0
Next
[c1].Resize(UBound(arr, 1), 1) = arr
Set reg = Nothing
Set sols = Nothing
End Sub

扫二维码下载贴吧客户端

下载贴吧APP
看高清直播、视频！

1 2 下一页尾页
62回复贴，共2页
，跳到页

<<返回excel吧

分享到:

日	一	二	三	四	五	六