Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 723|回复: 22

[已解决] [已解决]自已太菜两天没搞定, 求助大神老师帮帮忙做到文件去

[复制链接]
发表于 2017-5-21 09:29 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
自已太菜了折腾了两天搞不定,求助大神老师帮帮忙做到文件去,万分感 谢!
统计从表6“产品1”开始一直到表N“产品N”,因为日后会有产品5、6、7.。。。。。。,统计结果如下,品名、品号这个是每页固定位置的,每个产品的其他参数差别很大不一定隔几行才到要统计的数据。制作方法的行数每个产品不一样,而且会经常更新改进增加行减少行。制作个宏,通过查找每页的“工段一”到“工段七”所在的行,一按自动统计就能把表6开始到表N的品名、品号、部件、零件、工序、机台。。。。。等后面一整行数据都一起列出来,“部件”为空的行不要复制,整列有合并单元格的复制一个单元格就好了,这样以便统计。谢谢老师!
自动统计图.JPG

产品核算TEST.rar

130.08 KB, 下载次数: 20

金币
20  
积分
26 
帖子
1 

6

grf1973发布于 2017-5-22 10:15:50 |显示全部回帖
代码在“模块1”。结果秒出。
  1. Sub grf()
  2.     Dim sh As Worksheet, xrng As Range
  3.     Dim arr(1 To 10000, 1 To 18)
  4.     cz = Array(1, 2, 3, 5, 7, 9, 11, 13, 15, 17, 18, 19, 20, 21, 22, 23)   '要倒腾到自动统计表中的列
  5.     For Each sh In Worksheets
  6.         If sh.Name Like "产品*" Then
  7.             mc = sh.[c1]: ph = sh.[h1]   '名称、品号
  8.             Set xrng = sh.[a:a].Find("工段", lookat:=xlWhole)
  9.             If Not xrng Is Nothing Then
  10.                 r = sh.[b65536].End(3).Row
  11.                 brr = sh.Range(xrng, sh.Cells(r, "W"))   '要倒腾的数据源
  12.                 For i = 2 To UBound(brr)
  13.                     If brr(i, 1) = "" Then brr(i, 1) = brr(i - 1, 1)
  14.                     If brr(i, 2) <> "" And brr(i, 3) <> "零件" Then
  15.                         n = n + 1
  16.                         arr(n, 1) = mc: arr(n, 2) = ph
  17.                         For k = 3 To 18
  18.                             arr(n, k) = brr(i, cz(k - 3))
  19.                         Next
  20.                     End If
  21.                 Next
  22.             End If
  23.         End If
  24.     Next
  25.     [a4:r10000] = ""
  26.     [a4].Resize(n, 18) = arr
  27. End Sub
复制代码
发表于 2017-5-21 14:39 | 显示全部楼层
本帖最后由 327718098 于 2017-5-21 15:18 编辑

就服你这么多的合并单元格,这个运行起来有点慢,我测试了下你附件里的数据一个用了3分多种可能加上value在改两个地方可能会在快一点
Sub text()
Application.ScreenUpdating = False
Dim rng As Range, xh As Byte, hh As Long, xx As Byte, dd As Byte
For xh = 1 To Worksheets.Count - 5 Step 1
For Each rng In Worksheets("产品" & xh).Range _
(Worksheets("产品" & xh).Range("a:A").Find("工段").Offset(1, 1), _
Worksheets("产品" & xh).Cells(Rows.Count, "B").End(3))
If rng.Value = "" Or rng.Value = "部件" Then
GoTo tz
Else
With Sheet2
hh = .Cells(Rows.Count, 1).End(3).Row + 1
.Cells(hh, 1) = Worksheets("产品" & xh).Cells(1, "c")
.Cells(hh, 2) = Worksheets("产品" & xh).Cells(1, "h")
.Cells(hh, 3) = IIf(rng.Offset(, -1) = "", rng.Offset(, -1).End(xlUp), rng.Offset(, -1))
.Cells(hh, 4) = rng.Value
dd = 1
For xx = 5 To 11 Step 1
.Cells(hh, xx) = rng.Offset(, dd)
dd = dd + 2
Next
rng.Offset(, 15).Resize(1, 7).Copy
.Cells(hh, 12).PasteSpecial Paste:=xlPasteValues
End With
End If
tz: Next
Next
Application.ScreenUpdating = True
End Sub

回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-21 15:49 | 显示全部楼层
本帖最后由 yochlee 于 2017-5-21 15:54 编辑

谢谢327718098老师,可是现在产品工作表只能命名为产品1到N才行了,能不能改成随意命名呢,也是就可以从表6开始开始到表N。换个思路会不会快很多,先只管把符合的行全部复制过来,包括第一行的标题都复制一次,自动统计页中就不要有之前设定的筛选的标题行了。全部复制好在结束前再来判断标题行为空的列删除,部件列为空的行删除后再来设定标题行的筛选。谢谢老师,真是太麻烦您了,帮我这么多,您真是水平高的大好人

回复 支持 反对

使用道具 举报

发表于 2017-5-21 15:50 | 显示全部楼层
这样会快一点,但也花了2分26秒

Sub text()
t = Time
Application.ScreenUpdating = False
Dim rng As Range, xh As Byte, hh As Long, xx As Byte, dd As Variant
dd = Array(1, 3, 5, 7, 9, 11, 13)
For xh = 1 To Worksheets.Count - 5 Step 1
For Each rng In Worksheets("产品" & xh).Range _
(Worksheets("产品" & xh).Range("a:A").Find("工段").Offset(1, 1), _
Worksheets("产品" & xh).Cells(Rows.Count, "B").End(3))
If rng.Value = "" Or rng.Value = "部件" Then
GoTo tz
Else
With Sheet2
hh = .Cells(Rows.Count, 1).End(3).Row + 1
.Cells(hh, 1).Value = Worksheets("产品" & xh).Cells(1, "c").Value
.Cells(hh, 2).Value = Worksheets("产品" & xh).Cells(1, "h").Value
.Cells(hh, 3).Value = IIf(rng.Offset(, -1).Value = "", rng.Offset(, -1).End(xlUp).Value, rng.Offset(, -1).Value)
.Cells(hh, 4).Value = rng.Value
For xx = 5 To 11 Step 1
.Cells(hh, xx).Value = rng.Offset(, dd(xx - 5)).Value
Next
rng.Offset(, 15).Resize(1, 7).Copy
.Cells(hh, 12).PasteSpecial Paste:=xlPasteValues
End With
End If
tz:  Next
Next
Application.ScreenUpdating = True
MsgBox Format(Time - t, "hh:mm:ss")
End Sub

回复 支持 反对

使用道具 举报

发表于 2017-5-21 15:54 | 显示全部楼层
本帖最后由 327718098 于 2017-5-21 15:58 编辑
yochlee 发表于 2017-5-21 15:49
谢谢327718098老师,可是现在产品工作表只能命名为产品1到N才行了,能不能改成随意命名呢,也是就可以从表6 ...

一次性复制粘贴肯定快,但你那里面的合并单元格都得全部复制过去,现在得出去趟,有空在看看
随意工作表这个简单For xh = 6 To Worksheets.Count Step 1
For Each rng In Worksheets(xh).Range _
(Worksheets(xh).Range("a:A").Find("工段").Offset(1, 1), _
Worksheets(xh).Cells(Rows.Count, "B").End(3)
这样就行

回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-21 16:40 | 显示全部楼层
327718098 发表于 2017-5-21 15:54
一次性复制粘贴肯定快,但你那里面的合并单元格都得全部复制过去,现在得出去趟,有空在看看
随意工作表 ...

谢谢老师,我太菜了只好一直麻烦老师您。这句话放上去是有编译错误提醒,会不会是前面的工作表里也有工段的字段吧,可能还是要先排除前面5个表再开始提取,感谢老师!
回复 支持 反对

使用道具 举报

发表于 2017-5-21 18:00 | 显示全部楼层
yochlee 发表于 2017-5-21 16:40
谢谢老师,我太菜了只好一直麻烦老师您。这句话放上去是有编译错误提醒,会不会是前面的工作表里也有 ...

不是的没注意下面还有两句也要改,这两句挨着的 把("产品" & )删掉不要
.Cells(hh, 1).Value = Worksheets("产品" & xh).Cells(1, "c").Value
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-21 18:27 | 显示全部楼层
老师就是
For xh = 6 To Worksheets.Count Step 1
For Each rng In Worksheets(xh).Range _
(Worksheets(xh).Range("a:A").Find("工段").Offset(1, 1), _
Worksheets(xh).Cells(Rows.Count, "B").End(3))
这一段提示对象变量或with块变量未设置
回复 支持 反对

使用道具 举报

发表于 2017-5-21 20:25 | 显示全部楼层
yochlee 发表于 2017-5-21 18:27
老师就是
For xh = 6 To Worksheets.Count Step 1
For Each rng In Worksheets(xh).Range _

这不是没问题吗?
捕获.PNG
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-21 21:50 | 显示全部楼层
谢谢老师终于能用了
就是时间太久了
换个思路会不会快很多,除品名、品号外先只管把符合的行全部复制到自动统计(包括空格),也包括第一行的标题都复制一次(只复制到首行后面的不用复制),自动统计页中就不要有之前设定的筛选的标题行了。全部复制好在结束前再来判断标题行为空的列删除,部件列为空的行删除后再来设定标题行的筛选。这样会快很多吗
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2017-8-21 23:57 , Processed in 0.078001 second(s), 33 queries , Gzip On, Memcache On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

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