Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

工作中常用的Excel函数公式,全印在一张超大鼠标垫上
查看: 175|回复: 7

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

[复制链接]
发表于 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之后的结果。


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




最佳答案
2021-9-18 20:22
ryoryo66 发表于 2021-9-18 18:53
就是说,F1:K1的数就是6个位置的数字,这6个位置在21行里依次的显示出来了(我手工标红的).这6个位置标红出 ...
  1. Sub sadf()
  2. Dim arr1
  3. Dim arr(1 To 1000)
  4. Dim arr2, arr3
  5. Dim k, i, j, x, y, m, kk As Integer
  6. On Error Resume Next
  7. k = 0: y = 22
  8. arr1 = Range("f3:AM20")
  9. Rows("21:200").ClearContents '清除内容
  10. For i = 1 To UBound(arr1)
  11.     For j = 1 To UBound(arr1, 2)
  12.         If arr1(i, j) <> "" Then
  13.             k = k + 1
  14.             arr(k) = arr1(i, j)
  15.         End If
  16.     Next
  17. Next
  18. Range("f21").Resize(1, k) = arr '以上部分将f3:AM20内的数排成一行,放于第21行
  19. '以下部分按f1:k1位置分为7部分,最后一部分为从第K1+1位到最后
  20. arr2 = Range("f1:k1")
  21. x = 1
  22. m = 0
  23. ReDim arr3(1 To 1)
  24. For kk = 1 To UBound(arr2, 2) + 1
  25.     If kk <= UBound(arr2, 2) Then
  26.         For i = x To arr2(1, kk) - 1
  27.             m = m + 1
  28.             ReDim Preserve arr3(1 To m)
  29.             arr3(m) = arr(i)
  30.         Next
  31.     Else
  32.         If arr2(1, kk - 1) < k Then
  33.             For i = arr2(1, kk - 1) + 1 To k
  34.                 m = m + 1
  35.                 ReDim Preserve arr3(1 To m)
  36.                 arr3(m) = arr(i)
  37.             Next
  38.         End If
  39.     End If
  40.         y = y + 1
  41.         Range("f" & y).Resize(1, m) = arr3
  42.         Erase arr3
  43.         m = 0
  44.         x = arr2(1, kk) + 1
  45. Next
  46. End Sub
复制代码
你验证一下结果是否正确


1.rar

444.57 KB, 下载次数: 9

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2021-9-18 17:09 | 显示全部楼层
  1. Option Explicit

  2. Sub sadf()
  3. Dim arr1
  4. Dim arr(1 To 1000)
  5. Dim arr2
  6. Dim k, i, j, y, x As Integer
  7. On Error Resume Next
  8. k = 0: x = 0: y = 22
  9. arr1 = Range("f3:AM20")
  10. Rows("21:200").ClearContents '清除内容
  11. For i = 1 To UBound(arr1)
  12.     For j = 1 To UBound(arr1, 2)
  13.         If arr1(i, j) <> "" Then
  14.             k = k + 1
  15.             arr(k) = arr1(i, j)
  16.         End If
  17.     Next
  18. Next
  19. Range("f21").Resize(1, k) = arr '以上部分将f3:AM20内的数排成一行,放于第21行
  20. ReDim arr2(1 To 1)
  21. '以下部分按是否填充颜色分组,依次写入,从第23行开始
  22. For i = 1 To k
  23.     If Cells(21, i + 5).Interior.Pattern = xlNone Then
  24.         x = x + 1
  25.         ReDim Preserve arr2(1 To x)
  26.         arr2(x) = arr(i)
  27.     Else
  28.         y = y + 1
  29.         Range("f" & y).Resize(1, x) = arr2
  30.         Erase arr2
  31.         x = 0
  32.     End If
  33.     If i = k Then Range("f" & y + 1).Resize(1, x) = arr2
  34. Next
  35. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2021-9-18 17:34 | 显示全部楼层

感谢老师帮助。

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

使用道具 举报

发表于 2021-9-18 18:18 | 显示全部楼层
ryoryo66 发表于 2021-9-18 17:34
感谢老师帮助。

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

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

回复

使用道具 举报

 楼主| 发表于 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个位置提取.
就是这个意思.


回复

使用道具 举报

发表于 2021-9-18 20:22 | 显示全部楼层    本楼为最佳答案   
ryoryo66 发表于 2021-9-18 18:53
就是说,F1:K1的数就是6个位置的数字,这6个位置在21行里依次的显示出来了(我手工标红的).这6个位置标红出 ...
  1. Sub sadf()
  2. Dim arr1
  3. Dim arr(1 To 1000)
  4. Dim arr2, arr3
  5. Dim k, i, j, x, y, m, kk As Integer
  6. On Error Resume Next
  7. k = 0: y = 22
  8. arr1 = Range("f3:AM20")
  9. Rows("21:200").ClearContents '清除内容
  10. For i = 1 To UBound(arr1)
  11.     For j = 1 To UBound(arr1, 2)
  12.         If arr1(i, j) <> "" Then
  13.             k = k + 1
  14.             arr(k) = arr1(i, j)
  15.         End If
  16.     Next
  17. Next
  18. Range("f21").Resize(1, k) = arr '以上部分将f3:AM20内的数排成一行,放于第21行
  19. '以下部分按f1:k1位置分为7部分,最后一部分为从第K1+1位到最后
  20. arr2 = Range("f1:k1")
  21. x = 1
  22. m = 0
  23. ReDim arr3(1 To 1)
  24. For kk = 1 To UBound(arr2, 2) + 1
  25.     If kk <= UBound(arr2, 2) Then
  26.         For i = x To arr2(1, kk) - 1
  27.             m = m + 1
  28.             ReDim Preserve arr3(1 To m)
  29.             arr3(m) = arr(i)
  30.         Next
  31.     Else
  32.         If arr2(1, kk - 1) < k Then
  33.             For i = arr2(1, kk - 1) + 1 To k
  34.                 m = m + 1
  35.                 ReDim Preserve arr3(1 To m)
  36.                 arr3(m) = arr(i)
  37.             Next
  38.         End If
  39.     End If
  40.         y = y + 1
  41.         Range("f" & y).Resize(1, m) = arr3
  42.         Erase arr3
  43.         m = 0
  44.         x = arr2(1, kk) + 1
  45. Next
  46. End Sub
复制代码
你验证一下结果是否正确


回复

使用道具 举报

发表于 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,)&"")
8863.png
回复

使用道具 举报

发表于 2021-9-22 11:17 | 显示全部楼层
F2 右拉 {=IFERROR(OFFSET($B1,MATCH(1,COUNTIF($D:$D,$B1:$B20),)-COLUMN(A1)-1,),"")
8866.png
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2021-10-20 09:32 , Processed in 0.502735 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表