批量工作表的数据进转置重新排列数据

usedrange

ykcbf1100 发表于 2024-11-12 08:34
你应该是理解错了。
就设备1而言，是c7:g31这个区域的数据都要写过去的。
而且是分设备的。

感谢草爷提醒

usedrange

1. Sub tt()
   
2.     Dim wb, sh, i%, pa$, f, m%, sht
   
3.     pa = ThisWorkbook.Path & "\工序\CPK数据记录表（大沟）.xlsx"
   
4.     Set wb = GetObject(pa)
   
5.     m = 12
   
6.     For Each f In wb.Sheets
   
7.         With wb.Worksheets(f.Name)
   
8.             r = .[c6].End(4).Row
   
9.             sht = .[c6].Resize(r - 5, 5)
   
10.             For i = 6 To UBound(sht)
    
11.                 sh = .Range(.Cells(i, "c"), .Cells(i, "g"))
    
12.                 ActiveSheet.Cells(m, "d").Resize(UBound(sh, 2), 1) = Application.Transpose(sh)
    
13.                 m = ActiveSheet.Range("d1048576").End(xlUp).Row + 1
    
14.             Next i
    
15.         End With
    
16.     Next f
    
17.     wb.Close
    
18.     Set wb = Nothing
    
19. End Sub

复制代码

哈喽哈哈1

usedrange 发表于 2024-11-12 09:12
我理解错了，现在修改一下，看看是不是这个效果？

好的，非常感谢，我先试运行一下。

ykcbf1100

哈喽哈哈1 发表于 2024-11-12 08:48
老师你好，
    每个工作簿中有很多的产线，每条产线有也很多台设备，拆分的时候是按照设备进行拆分下来 ...

能正常拆分，但速度有点慢，仅供参考。。。

ykcbf1100

拆分速度有点慢，仅供参考。。。

1. Sub ykcbf()   '//2024.11.12
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     p = ThisWorkbook.Path & ""
   
7.     Set sh = ThisWorkbook.Sheets("CPK分析报告")
   
8.     f = p & "\工序\CPK数据记录表（大沟）.xlsx"
   
9.     p2 = p & "报告存储单"
   
10.     Dim tm: tm = Timer
    
11.     Set wb1 = Workbooks.Open(f, 0)
    
12.     For Each sht In wb1.Sheets
    
13.         With sht
    
14.             For j = 3 To 22 Step 5
    
15.                 st = .Cells(4, j).Value
    
16.                 l = InStr(st, "（")
    
17.                 st = Left(st, l - 1)
    
18.                 d(st) = j
    
19.             Next
    
20.         End With
    
21.     Next
    
22.     For Each k In d.keys
    
23.         m = 0
    
24.         ReDim brr(1 To 10000, 1 To 1)
    
25.         For Each sht In wb1.Sheets
    
26.             With sht
    
27.                 r = .Cells(Rows.Count, 1).End(3).Row
    
28.                 r1 = .Columns(1).Find("No.").Row
    
29.                 arr = .[a1].Resize(r, 22)
    
30.                 For j = 3 To UBound(arr, 2) Step 5
    
31.                     st = .Cells(4, j).Value
    
32.                     l = InStr(st, "（")
    
33.                     st = Left(st, l - 1)
    
34.                     If st = k Then
    
35.                         For i = r1 + 1 To UBound(arr)
    
36.                             For x = 1 To 5
    
37.                                 m = m + 1
    
38.                                 brr(m, 1) = arr(i, j + x - 1)
    
39.                             Next
    
40.                         Next
    
41.                         Exit For
    
42.                     End If
    
43.                 Next
    
44.             End With
    
45.         Next
    
46.         sh.Copy
    
47.         Set wb = ActiveWorkbook
    
48.         With wb.Sheets(1)
    
49.             .Name = k
    
50.             For Each btn In .OLEObjects
    
51.                 If btn.Name = "拆分" Then
    
52.                     btn.Delete
    
53.                     Exit For
    
54.                 End If
    
55.             Next btn
    
56.             .[d12].Resize(m, 1) = brr
    
57.         End With
    
58.         wb.SaveAs p2 & "CPK分析报告（" & k & "）"
    
59.         wb.Close
    
60.     Next
    
61.     wb1.Close 0
    
62.     Set d = Nothing
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
65. End Sub
    

复制代码

哈喽哈哈1

ykcbf1100 发表于 2024-11-12 10:17
拆分速度有点慢，仅供参考。。。

草爷
     For Each btn In .OLEObjects    我这里运行的时候这行代码会报错，你哪里会吗？

ykcbf1100

哈喽哈哈1 发表于 2024-11-12 10:52
草爷
     For Each btn In .OLEObjects    我这里运行的时候这行代码会报错，你哪里会吗？

这段代码删除。。

usedrange

整了个完整版，看看行不行

哈喽哈哈1

usedrange 发表于 2024-11-12 12:10
整了个完整版，看看行不行

谢谢老师，就是这种情况。   还有一个点想请教一下。
ActiveWorkbook.SaveCopyAs savePt & "\" & na & ".xls"       ', xlOpenXMLWorkbook
   这行代码是保存的表格为旧版的，为什么我excel版本比较高，这个能怎么去更新。我想保存为xlsx这种的

usedrange

哈喽哈哈1 发表于 2024-11-13 08:48
谢谢老师，就是这种情况。   还有一个点想请教一下。
ActiveWorkbook.SaveCopyAs savePt & "\" & na & " ...

ActiveWorkbook.SaveCopyAs savePt & "\" & na & ".xlsx"       ', xlOpenXMLWorkbook
这样就可以保存为xlsx了，因为xlOpenXMLWorkbook的保存类型就是xlsx的，我忘记改过来了