Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2410|回复: 5

[已解决]求大神帮忙

[复制链接]
发表于 2015-8-22 18:05 | 显示全部楼层 |阅读模式
还是海运公司的那个卤煮又来了,上次在论坛的那个问题得到了很大的解决,这一次还有一个很大问题,请各位赐教。
楼主还是做表格的,这次呢做的的表格呢,非常让人吐血,如下图一所示,就是四个提单号为模板,然后根据上头的指令,告诉你要复制4个提单号的数量,不只是简单的复制哦,具体规则见下面
能否设计出这样的一个程序:17列的箱型代码为2种,一种为20gp,一种为40gp.18列的状态代码为F,E。能否设计一个功能就是比如我要20个20gp的f代码(根据对应箱型代码与状态代码对应的提运单号向下复制20个每个单号不重复,累加1就可以,集装箱箱号与铅封也是与运单号一致的规则,其他的列复制就好)得出20个20gp状态代码为f的20行数据,其他的如果没有要求就不要显示。
举个例子,我要2个箱型(代码为20gp,状态代码为f),3个箱型(代码为40hc,状态代码为f),4个箱型(代码为20gp,状态代码为e),希望生成的表格为见图二。
具体的模板和结果卤煮都有上传,望大神能看懂能理解,要是描述不清楚欢迎24小时提问感谢感谢
最佳答案
2015-8-25 10:18
请看附件。

图一

图一

图二

图二

格式表与结果表.rar

20.35 KB, 下载次数: 5

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2015-8-24 10:24 | 显示全部楼层
回复

使用道具 举报

发表于 2015-8-24 11:40 | 显示全部楼层
  1. Sub tt()
  2.     ts = Cells(2, 24) '条数
  3.     If Val(ts) = 0 Then Exit Sub
  4.     xx = UCase(Cells(2, 22)) '箱型
  5.     zt = UCase(Cells(2, 23)) '状态
  6.     arr = [a1].CurrentRegion
  7.     Set d = CreateObject("scripting.dictionary")
  8.     For i = 2 To UBound(arr)
  9.         x = arr(i, 18) & arr(i, 19)     '箱型+状态为key
  10.         d(x) = i
  11.     Next
  12.    
  13.     x = xx & zt
  14.     With Sheet2
  15.         r = .[a65536].End(3).Row
  16.         If r > 1 Then        '先检查结果表中是否有相应记录,如有,在取此记录对应的单号、箱号、铅封
  17.             brr = .[a1].CurrentRegion
  18.             For i = 2 To UBound(brr)
  19.                 y = brr(i, 18) & brr(i, 19)     '箱型+状态为key
  20.                 If y = x Then p = i
  21.             Next
  22.         End If
  23.         If p > 0 Then     '结果表中有相应记录,在此记录后累加
  24.             dh = brr(p, 1): xh = brr(p, 17): qf = brr(p, 20)          '单号、箱号、铅封
  25.         Else               '结果表中无相应记录,在此记录后累加
  26.             If d.exists(x) Then
  27.                 dh = arr(d(x), 1): xh = arr(d(x), 17): qf = arr(d(x), 20)
  28.             Else
  29.                 MsgBox "无匹配记录": Exit Sub
  30.             End If
  31.         End If
  32.         ReDim crr(1 To ts, 1 To UBound(arr, 2))
  33.         For i = 1 To ts
  34.             If i > 1 Or p > 0 Then dh = GetNew(dh): xh = GetNew(xh): qf = GetNew(qf)
  35.             For j = 1 To UBound(arr, 2)
  36.                 If p > 0 Then crr(i, j) = brr(p, j) Else crr(i, j) = arr(d(x), j)
  37.             Next
  38.             crr(i, 1) = dh: crr(i, 17) = xh: crr(i, 20) = qf
  39.         Next
  40.         .Cells(r + 1, 1).Resize(ts, UBound(crr, 2)) = crr
  41.         .Activate
  42.     End With
  43. End Sub

  44. Function GetNew(xstr)       '取得xstr+1(字母数字混合型)
  45.     If xstr = "" Then GetNew = "": Exit Function
  46.     For i = Len(xstr) To 1 Step -1
  47.         If Not IsNumeric(Mid(xstr, i, 1)) Then p = i: Exit For
  48.     Next
  49.     If p = 0 Then
  50.         GetNew = Right("0" & Val(xstr) + 1, Len(xstr))
  51.     Else
  52.         sz = Mid(xstr, p + 1)
  53.         GetNew = Mid(xstr, 1, p) & Right("0" & Val(sz) + 1, Len(sz))
  54.     End If
  55. End Function
复制代码
回复

使用道具 举报

发表于 2015-8-24 11:40 | 显示全部楼层
请看附件。应该还可以简化一点的。

格式表.rar

22.68 KB, 下载次数: 7

回复

使用道具 举报

 楼主| 发表于 2015-8-24 13:50 | 显示全部楼层
grf1973 发表于 2015-8-24 11:40
请看附件。应该还可以简化一点的。

厉害!!!!但是能不能把四个的数量都列出来,就是对应的四个选择都列出来,这样我每次只要修改一下量就好了,拜托。
1.png
2.png
回复

使用道具 举报

发表于 2015-8-25 10:18 | 显示全部楼层    本楼为最佳答案   
请看附件。

格式表.rar

22 KB, 下载次数: 12

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 03:50 , Processed in 0.557990 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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