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

327718098

yochlee 发表于 2017-5-21 21:50
谢谢老师终于能用了
就是时间太久了
换个思路会不会快很多， ...

有合并单元格方便统计吗

yochlee

327718098 发表于 2017-5-21 22:00
有合并单元格方便统计吗

老师全部复制好在结束前再来判断标题行为空的列删除，部件列为空的行删除后再来设定标题行的筛选。这样得到的数据应该是一样的吧

yochlee

327718098 发表于 2017-5-21 22:00
有合并单元格方便统计吗

老师如图这样能实现吗

327718098

yochlee 发表于 2017-5-21 22:24
老师如图这样能实现吗

Sub text1()
s = Time
Application.ScreenUpdating = False
Sheet2.Range("A" & Cells(Rows.Count, 1).End(3).Row + 1).Value = Sheets(6).Range("a1").Value
Sheet2.Range("b" & Cells(Rows.Count, 1).End(3).Row).Value = Sheets(6).Range("g1").Value
Dim xh As Byte, rng As Range, rng1 As Range
Worksheets(6).Range("A:A").Find("工段").Resize(1, 23).Copy
Sheet2.Range("c" & Cells(Rows.Count, 1).End(3).Row + 1).Offset(-1, 0).PasteSpecial Paste:=xlPasteValues
For xh = 6 To Worksheets.Count Step 1
Worksheets(xh).Range(Worksheets(xh).Range("a:A").Find("工段").Offset(1, 0), "w" & Worksheets(xh).Cells(Rows.Count, 1).End(3).EntireRow.Row).Copy
Sheet2.Range("c" & Cells(Rows.Count, 3).End(3).Row + 1).PasteSpecial Paste:=xlPasteValues
Sheet2.Range("b" & Cells(Rows.Count, 3).End(3).Row) = Worksheets(xh).Range("h1").Value
Sheet2.Range("a" & Cells(Rows.Count, 3).End(3).Row) = Worksheets(xh).Range("c1").Value
Next
For Each rng In Sheet2.Range("d4", Sheet2.Range("d1000000").End(xlUp))
rng.Offset(0, -2).Value = IIf(rng.Offset(0, -2).Value = "", rng.Offset(0, -2).End(xlDown).Value, rng.Offset(0, -2).Value)
rng.Offset(0, -3).Value = IIf(rng.Offset(0, -3).Value = "", rng.Offset(0, -3).End(xlDown).Value, rng.Offset(0, -3).Value)
If rng.Offset(0, -1).Value = "" Then
rng.Offset(0, -1).Value = rng.Offset(0, -1).End(3).Value
End If
If rng.Value = "部件" Or rng.Value = "" Then
If rng1 Is Nothing Then
Set rng1 = rng.EntireRow
Else
Set rng1 = Union(rng1, rng.EntireRow)
End If
End If
Next
rng1.Delete
Set rng1 = Nothing
For Each rng In Sheet2.Range("A3:w3")
If rng.Value = "" Then
If rng1 Is Nothing Then
Set rng1 = rng.EntireColumn
Else
Set rng1 = Union(rng1, rng.EntireColumn)
End If
End If
Next
Set rng1 = Union(rng1, Rows(Cells(Rows.Count, "d").End(3).Row + 1 & ":" & Cells(Rows.Count, "d").End(3).Row + 3).Select)
rng1.Delete
Application.ScreenUpdating = True
MsgBox "本次运行耗时" & Format(Time - s, "hh小时mm分ss秒")
End Sub

grf1973

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

复制代码

grf1973

换个sql的方法。

yochlee

太感谢327718098和grf1973两位老师了，多谢您们的热心帮忙，无限感激

yochlee

grf1973 发表于 2017-5-22 11:09
换个sql的方法。

老师您这太深了，我原表就差这么点过不来，您再帮我看下改好来好么
1、循表改成从表大于几开始，要不不叫产品几的表格都不行了
2、产品表里一行空格后AO到BE列数据也要复制过来
老师我模板样式发给您帮我看下
拜谢老师

grf1973

请看附件。

grf1973

因为代码里无法显示有些列字段名（m3这样的显示不出来），所以只好用全选的办法，再删除空列