[已解决]求助一个代码应该怎么达成？

ryoryo66 · 发表于 2021-9-18 16:20

总的思路是从F3到AM20的范围内，把数字按表中每行接连起来（比如F21：AL21开始），一共是33个数字。
然后按F1：K1的数字，比如我在F21：AL21中把这6个数字的所在位置标出来了。
需求是把
第1个数字位置前面的数字；
第1个数字位置与第2个数字位置之间的数字；
第2个数字位置与第3个数字位置之间的数字；
第3个数字位置与第4个数字位置之间的数字；
第4个数字位置与第5个数字位置之间的数字；
第5个数字位置与第6个数字位置之间的数字；
第6个数字位置之后的数字。
这些全都返回出来。如F23之后的结果。

请问这个代码应该怎么写啊？

最佳答案

月排行榜 / 总排行榜

lisongmei

2021-9-18 20:22

ryoryo66 发表于 2021-9-18 18:53
就是说,F1:K1的数就是6个位置的数字,这6个位置在21行里依次的显示出来了(我手工标红的).这6个位置标红出 ...

Sub sadf()
Dim arr1
Dim arr(1 To 1000)
Dim arr2, arr3
Dim k, i, j, x, y, m, kk As Integer
On Error Resume Next
k = 0: y = 22
arr1 = Range("f3:AM20")
Rows("21:200").ClearContents '清除内容
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr1, 2)
If arr1(i, j) <> "" Then
k = k + 1
arr(k) = arr1(i, j)
End If
Next
Next
Range("f21").Resize(1, k) = arr '以上部分将f3:AM20内的数排成一行，放于第21行
'以下部分按f1:k1位置分为7部分，最后一部分为从第K1+1位到最后
arr2 = Range("f1:k1")
x = 1
m = 0
ReDim arr3(1 To 1)
For kk = 1 To UBound(arr2, 2) + 1
If kk <= UBound(arr2, 2) Then
For i = x To arr2(1, kk) - 1
m = m + 1
ReDim Preserve arr3(1 To m)
arr3(m) = arr(i)
Next
Else
If arr2(1, kk - 1) < k Then
For i = arr2(1, kk - 1) + 1 To k
m = m + 1
ReDim Preserve arr3(1 To m)
arr3(m) = arr(i)
Next
End If
End If
y = y + 1
Range("f" & y).Resize(1, m) = arr3
Erase arr3
m = 0
x = arr2(1, kk) + 1
Next
End Sub

复制代码

你验证一下结果是否正确

跳转到最佳答案楼层

lisongmei · 发表于 2021-9-18 17:09

Option Explicit
Sub sadf()
Dim arr1
Dim arr(1 To 1000)
Dim arr2
Dim k, i, j, y, x As Integer
On Error Resume Next
k = 0: x = 0: y = 22
arr1 = Range("f3:AM20")
Rows("21:200").ClearContents '清除内容
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr1, 2)
If arr1(i, j) <> "" Then
k = k + 1
arr(k) = arr1(i, j)
End If
Next
Next
Range("f21").Resize(1, k) = arr '以上部分将f3:AM20内的数排成一行，放于第21行
ReDim arr2(1 To 1)
'以下部分按是否填充颜色分组，依次写入，从第23行开始
For i = 1 To k
If Cells(21, i + 5).Interior.Pattern = xlNone Then
x = x + 1
ReDim Preserve arr2(1 To x)
arr2(x) = arr(i)
Else
y = y + 1
Range("f" & y).Resize(1, x) = arr2
Erase arr2
x = 0
End If
If i = k Then Range("f" & y + 1).Resize(1, x) = arr2
Next
End Sub

复制代码

ryoryo66 · 发表于 2021-9-18 17:34

lisongmei 发表于 2021-9-18 17:09

感谢老师帮助。

'以下部分按是否填充颜色分组，依次写入，从第23行开始
这个是否可以改成按照F1:K1的的顺序数字，来确定位置，我上面填充的底色是方便您查看的。如果要是每次手动填充就很麻烦.

lisongmei · 发表于 2021-9-18 18:18

ryoryo66 发表于 2021-9-18 17:34
感谢老师帮助。

'以下部分按是否填充颜色分组，依次写入，从第23行开始

F1:K1数值虽然是从小到大排序的，但是在第21行里的顺序是乱置的，更大的数可能出现在更小数的前面，所以不知道你具体是想取哪个之间！
建议模拟一个正确的结果。（现在你标出来的跟F1:K1的数不一样）

ryoryo66 · 发表于 2021-9-18 18:53

本帖最后由 ryoryo66 于 2021-9-18 19:12 编辑

lisongmei 发表于 2021-9-18 18:18
F1:K1数值虽然是从小到大排序的，但是在第21行里的顺序是乱置的，更大的数可能出现在更小数的前面，所以 ...

就是说,F1:K1的数就是6个位置的数字,这6个位置在21行里依次的显示出来了(我手工标红的).这6个位置标红出来后,可以看出来,是按照那6个数字所在21行的位置.
这样的话,看得清楚,然后根据这6个位置提取.
就是这个意思.

lisongmei · 发表于 2021-9-18 20:22

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

单击隐藏图章

ryoryo66 发表于 2021-9-18 18:53
就是说,F1:K1的数就是6个位置的数字,这6个位置在21行里依次的显示出来了(我手工标红的).这6个位置标红出 ...

Sub sadf()
Dim arr1
Dim arr(1 To 1000)
Dim arr2, arr3
Dim k, i, j, x, y, m, kk As Integer
On Error Resume Next
k = 0: y = 22
arr1 = Range("f3:AM20")
Rows("21:200").ClearContents '清除内容
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr1, 2)
If arr1(i, j) <> "" Then
k = k + 1
arr(k) = arr1(i, j)
End If
Next
Next
Range("f21").Resize(1, k) = arr '以上部分将f3:AM20内的数排成一行，放于第21行
'以下部分按f1:k1位置分为7部分，最后一部分为从第K1+1位到最后
arr2 = Range("f1:k1")
x = 1
m = 0
ReDim arr3(1 To 1)
For kk = 1 To UBound(arr2, 2) + 1
If kk <= UBound(arr2, 2) Then
For i = x To arr2(1, kk) - 1
m = m + 1
ReDim Preserve arr3(1 To m)
arr3(m) = arr(i)
Next
Else
If arr2(1, kk - 1) < k Then
For i = arr2(1, kk - 1) + 1 To k
m = m + 1
ReDim Preserve arr3(1 To m)
arr3(m) = arr(i)
Next
End If
End If
y = y + 1
Range("f" & y).Resize(1, m) = arr3
Erase arr3
m = 0
x = arr2(1, kk) + 1
Next
End Sub

复制代码

你验证一下结果是否正确

hcm19522 · 发表于 2021-9-20 17:47

本帖最后由 hcm19522 于 2021-9-21 14:47 编辑

參考
E3:H8=IF(COUNTIF($D$3:$D$8,OFFSET($B$1,MATCH($D3,$B:$B,)+COLUMN(A1)-1,))+(D3=""),"",OFFSET($B$1,MATCH($D3,$B:$B,)+COLUMN(A1)-1,)&"")

hcm19522 · 发表于 2021-9-22 11:17

F2 右拉 {=IFERROR(OFFSET($B1,MATCH(1,COUNTIF($D:$D,$B1:$B20),)-COLUMN(A1)-1,),"")

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