[已解决]组合数据并提取出来的问题

Baibdu · 发表于 2015-1-12 10:40

本帖最后由 Baibdu 于 2015-1-12 16:29 编辑

附件

提取数据附件.rar (36.14 KB, 下载次数: 16)

grf1973 · 发表于 2015-1-12 11:55

Sub tt()
arr = [a1].CurrentRegion
Dim brr(1 To 10000, 1 To 2)
a = 47: b = 47
For i = 1 To UBound(arr)
For j = UBound(arr, 2) To 2 Step -1
x = arr(i, j)
If t = 0 And x = a Then
y1 = arr(i, j - 2): y2 = arr(i, j - 1)
brr(n + 2, 1) = "'" & Format(y1, "00") & Format(y2, "00") & Format(a, "00")
t = t + 1
ElseIf t = 1 And x = b Then
y1 = arr(i, j - 2): y2 = arr(i, j - 1)
brr(n + 1, 1) = "'" & Format(y1, "00") & Format(y2, "00") & Format(a, "00")
brr(n + 1, 2) = arr(i, j + 1)
t = 0
n = n + 2
End If
Next
Next
Sheet2.[a1].Resize(n + 2, 2) = brr
End Sub

复制代码

grf1973 · 发表于 2015-1-12 11:57

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

请看附件。没有很严谨的考虑数组的边界。本组数据没有报错。

Baibdu · 发表于 2015-1-12 12:27

grf1973 发表于 2015-1-12 11:57
请看附件。没有很严谨的考虑数组的边界。本组数据没有报错。

老师您好，谢谢您帮助。
下载试了一下，发现有个小问题。

附件中，一共261行数据，那么表2的结果，应该是522行，实际运行出来的结果却有524行。
再仔细一对比，发现结果中的，第二组数据，不知是从哪里来的。表1中，没有相对应的行。
麻烦老师看看，再谢。

Baibdu · 发表于 2015-1-12 12:40

grf1973 发表于 2015-1-12 11:57
请看附件。没有很严谨的考虑数组的边界。本组数据没有报错。

刚才仔细看了一下，才发现，原来，结果中的第二组数据，也是来自第一行。
这个问题，附件中忽略了，也就是，每一行中，只能提取从左到右，一组数据，而不能同时提取两组。
附件中的数据，因进行了严格的筛选，除了第一行人为加进去多个47外，其余行，都只有两个47，因此造成了假象。
实际中，并不是这样的，比如：如果要输入两个数，是相同的，47 47，而这个数，在每一行，都铁定有5个，那么，只能选从右到左（即从后面到前面）最前面两个。输入不同的两个数，也是一样，总是选最前面的一个或两个。

grf1973 · 发表于 2015-1-12 12:58

小改一下就行了，找到第二个数后就跳出内循环

Sub tt()
arr = [a1].CurrentRegion
Dim brr(1 To 10000, 1 To 2)
a = 47: b = 47
For i = 1 To UBound(arr)
For j = UBound(arr, 2) To 2 Step -1
x = arr(i, j)
If t = 0 And x = a Then
y1 = arr(i, j - 2): y2 = arr(i, j - 1)
brr(n + 2, 1) = "'" & Format(y1, "00") & Format(y2, "00") & Format(a, "00")
t = t + 1
ElseIf t = 1 And x = b Then
y1 = arr(i, j - 2): y2 = arr(i, j - 1)
brr(n + 1, 1) = "'" & Format(y1, "00") & Format(y2, "00") & Format(a, "00")
brr(n + 1, 2) = arr(i, j + 1)
t = 0
n = n + 2
Exit For
End If
Next
Next
Sheet2.[a1].Resize(n + 2, 2) = brr
End Sub

复制代码

Baibdu · 发表于 2015-1-12 15:34

grf1973 发表于 2015-1-12 12:58
小改一下就行了，找到第二个数后就跳出内循环

谢谢老师了。试了一下，如果是纯两位数，运行正常。但遇上带0头的两位数，在代码里，就会出现问题，我搞不懂这里为什么。比如：输入两个数，47 7，出来的结果，六位数里，后面两位全部是47，我又在代码里，把7改为两位数07，但不成功，手一离开，又变成一位数 7 了。

grf1973 · 发表于 2015-1-13 08:59

Baibdu 发表于 2015-1-12 15:34
谢谢老师了。试了一下，如果是纯两位数，运行正常。但遇上带0头的两位数，在代码里，就会出现问题，我搞不 ...

Sub tt()
arr = [a1].CurrentRegion
Dim brr(1 To 10000, 1 To 2)
a = 47: b = 7
For i = 1 To UBound(arr)
For j = UBound(arr, 2) To 2 Step -1
x = arr(i, j)
If t = 0 And x = a Then
y1 = arr(i, j - 2): y2 = arr(i, j - 1)
brr(n + 2, 1) = "'" & Format(y1, "00") & Format(y2, "00") & Format(a, "00")
t = t + 1
ElseIf t = 1 And x = b Then
y1 = arr(i, j - 2): y2 = arr(i, j - 1)
brr(n + 1, 1) = "'" & Format(y1, "00") & Format(y2, "00") & Format(b, "00")
brr(n + 1, 2) = arr(i, j + 1)
t = 0
n = n + 2
Exit For
End If
Next
Next
With Sheet2
.Cells.Clear
.[a1].Resize(n + 2, 2) = brr
.Activate
End With
End Sub

复制代码

grf1973 · 发表于 2015-1-13 09:00

有点小错误，改过来就好了

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