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

yochlee

自已太菜了折腾了两天搞不定，求助大神老师帮帮忙做到文件去，万分感 谢！
统计从表6“产品1”开始一直到表N“产品N”，因为日后会有产品5、6、7.。。。。。。，统计结果如下，品名、品号这个是每页固定位置的，每个产品的其他参数差别很大不一定隔几行才到要统计的数据。制作方法的行数每个产品不一样，而且会经常更新改进增加行减少行。制作个宏，通过查找每页的“工段一”到“工段七”所在的行，一按自动统计就能把表6开始到表N的品名、品号、部件、零件、工序、机台。。。。。等后面一整行数据都一起列出来，“部件”为空的行不要复制，整列有合并单元格的复制一个单元格就好了，这样以便统计。谢谢老师！

最佳答案

月排行榜 / 总排行榜

grf1973

2017-5-22 10:15

代码在“模块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
    

复制代码

跳转到最佳答案楼层

327718098

就服你这么多的合并单元格，这个运行起来有点慢，我测试了下你附件里的数据一个用了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

yochlee

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

327718098

这样会快一点，但也花了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

327718098

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)
这样就行

yochlee

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

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

327718098

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

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

yochlee

老师就是
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块变量未设置

327718098

yochlee 发表于 2017-5-21 18:27
老师就是
For xh = 6 To Worksheets.Count Step 1
For Each rng In Worksheets(xh).Range _

这不是没问题吗？

yochlee

谢谢老师终于能用了
就是时间太久了
换个思路会不会快很多，除品名、品号外先只管把符合的行全部复制到自动统计（包括空格），也包括第一行的标题都复制一次（只复制到首行后面的不用复制），自动统计页中就不要有之前设定的筛选的标题行了。全部复制好在结束前再来判断标题行为空的列删除，部件列为空的行删除后再来设定标题行的筛选。这样会快很多吗