[已解决]求助：上清宫主

ms967967 · 发表于 2014-2-6 18:46

本帖最后由 ms967967 于 2014-2-22 11:00 编辑

上清宫主帮我做的VBA在实际使用过程中遇到到了问题，请帮助解决。问题如附件，您在百忙之中对我的帮助深表感谢。

ms967967 · 发表于 2014-2-19 21:36

当附件只换成例二后，VBA代码更换为下面的代码（增加了TEXT），显示有错误，请大侠们帮助修改

Sub test()
Dim ar(), br()
i% = Range("A3").End(xlDown).Row
If Cells(i, 1) = "" Then Exit Sub
ar = Range("a3:c" & i).Value
ReDim br(1 To i * 2, 1 To 4)
For i = 3 To 1 Step -2
For i2% = 1 To UBound(ar)
      If stemp$ = ar(i2, i) Then
         br(r, 4) = br(r, 4) + 1
      Else
         r = r + 1
         br(r, 1) = Cells(i2 + 2, i).Comment.Text
         br(r, 2) = ar(i2, i)
         br(r, 3) = Left(br(r, 1), 2)
         br(r, 4) = 1
         If r > 1 Then br(r - 1, 1) = br(r - 1, 1) & "-" & Left(br(r - 1, 1), 3) & Text((Right(br(r - 1, 1), 2) + br(r - 1, 4) - 1), "00")
         stemp$ = ar(i2, i)
      End If
Next
Next
If r > 1 Then
br(r, 1) = br(r, 1) & "-" & Left(br(r, 1), 3) & Text((Right(br(r, 1), 2) + br(r, 4) - 1), "00")
[a19].Resize(r, 4) = br
End If
End Sub

ms967967 · 发表于 2014-2-20 21:28

期待了解的朋友帮助回答

ms967967 · 发表于 2014-2-21 20:38

请大侠给设置TEXT函数

dsmch · 发表于 2014-2-21 22:40

Sub Macro1()
Dim d, arr(1 To 20000, 1 To 4), i&, s&, j%, x$, pz$
Set d = CreateObject("scripting.dictionary")
For j = 1 To 3 Step 2
For i = 3 To 13
pz = Cells(i, j).Comment.Text
x = Cells(i, j) & "," & Left$(pz, 2)
If Not d.exists(x) Then
s = s + 1
d(x) = s
arr(s, 1) = pz
arr(s, 2) = Cells(i, j)
arr(s, 3) = Left(pz, 2)
arr(s, 4) = 1
Else
arr(d(x), 1) = arr(d(x), 1) & " " & pz
arr(d(x), 4) = arr(d(x), 4) + 1
End If
Next
Next
For i = 1 To s
y = Split(arr(i, 1))
If UBound(y) > 0 Then arr(i, 1) = y(0) & "-" & y(UBound(y))
Next
Range("f19").Resize(s, 4) = arr
End Sub

复制代码

dsmch · 发表于 2014-2-21 22:42

………………

ms967967 · 发表于 2014-2-22 07:22

dsmch 发表于 2014-2-21 22:42
………………

感谢你的支持，我在测试时还是发现了一个小问题。
例如一排机床的首尾两个单元格的内容一样；那么会出现，如下图

NE101-NE111

123456

NE

5

这里编号段出错了，而且5累加的结果，
请您再辛苦一下，帮帮忙了。

dsmch · 发表于 2014-2-22 08:31

ms967967 发表于 2014-2-22 07:22
感谢你的支持，我在测试时还是发现了一个小问题。
例如一排机床的首尾两个单元格的内容一样；那么会出现 ...

用测试附件说明问题，列出正确结果方便修改代码

ms967967 · 发表于 2014-2-22 08:59

dsmch 发表于 2014-2-22 08:31
用测试附件说明问题，列出正确结果方便修改代码

汇总单元格内容.zip (19.58 KB, 下载次数: 3)

dsmch · 发表于 2014-2-22 10:45

Sub Macro2()
Dim rng As Range, arr(1 To 10000, 1 To 4)
Dim i&, s&, x&, j%
[k:n].ClearContents
For j = 1 To 3 Step 2
Set rng = Cells(3, j)
x = Cells(65536, j).End(xlUp).Row + 1
For i = 4 To x
If Cells(i, j) <> rng Then
s = s + 1
pz = Cells(rng.Row, j).Comment.Text
pz2 = Cells(i - 1, j).Comment.Text
arr(s, 1) = pz & "-" & pz2
arr(s, 2) = rng
arr(s, 3) = Left$(pz, 2)
arr(s, 4) = i - rng.Row
Set rng = Cells(i, j)
End If
Next
Set rng = Nothing
Next
Range("k3").Resize(s, 4) = arr
End Sub

复制代码

		自动登录	找回密码
密码			注册

[已解决]求助：上清宫主

相关帖子