返回列表 上一主題 發帖

[發問] 重複列數移動至新工作表

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2015-9-27 22:37 | 只看該作者

[發問] 重複列數移動至新工作表

想請教VBA做法如下:

"總表" 中每4列數據為一組 -> 開新工作表-> 將每3組(共12列)資料連格式移動至新工作表.

求教! 每3組移動新工作表.rar (10.52 KB)
收藏 分享

kerochen

帖子
15 
主題
3 
精華
0 
積分
30 
點名
0  
作業系統
win7 
軟體版本
2010 
閱讀權限
10 
註冊時間
2014-5-29 
最後登錄
2015-10-23 
8#
發表於 2015-10-1 21:19 | 只看該作者
感謝好技巧. 雖然不是我發問的. 但受教了. 這是個很實用的例子.

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
7#
發表於 2015-9-28 18:40 | 只看該作者
  1. Sub TEST()
  2. Dim xS As Worksheet, SHN$, i&, j%
  3. With Sheets("總表")
  4. 　　For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row Step 12
  5. 　　　j = (i - 1) / 4 + 1
  6. 　　　SHN = j & "~" & j + 2 & "組"
  7. 　　　On Error Resume Next: Set xS = Sheets(SHN): On Error GoTo 0
  8. 　　　If xS Is Nothing Then Worksheets.Add(after:=Sheets(Sheets.Count)).Name = SHN
  9. 　　　Set xS = Sheets(SHN)
  10. 　
  11. 　　　.Cells(i, 1).Resize(12, 4).Copy xS.[A1]
  12. 　　　For j = 1 To 4: xS.Cells(1, j).ColumnWidth = .Cells(1, j).ColumnWidth: Next
  13. 　　　For j = 1 To 12: xS.Cells(j, 1).RowHeight = .Cells(j, 1).RowHeight: Next
  14. 　　　Set xS = Nothing
  15. 　　Next i
  16. End With
  17. End Sub
複製代碼
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
On Error Resume Next
Set xS = Sheets(SHN)
On Error GoTo 0
略過錯誤指令只針對 Set xS = Sheets(SHN)，
過後還是要恢復偵錯功能，否則遇錯誤無法檢知，對資料的正確性有風險！！！

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
6#
發表於 2015-9-28 15:10 | 只看該作者
回復 5# lpk187

感謝大大, 原來沒有xlpasteRowHeight 這東西, 所以只欠到高, 就乾脆定下列高就成功了.
  1. Sub ex()
  2.     On Error Resume Next
  3.     With Sheets("總表")
  4.     x = 1: y = 3
  5.         ro = .Cells(Rows.Count, 1).End(xlUp).Row
  6.         For I = 1 To ro Step 12
  7.             Set sh = Sheets(x & "~" & y & "組")
  8.             If sh Is Nothing Then
  9.                 Set sh = Worksheets.Add(After:=Sheets(Sheets.Count))
  10.                 sh.Name = x & "~" & y & "組"
  11.             End If
  12.             .Range("a" & I & ":D" & I + 11).Copy
  13.             Sheets(sh.Name).Range("A1:D12").PasteSpecial xlPasteColumnWidths
  14.             Sheets(sh.Name).Range("A1:D12").PasteSpecial xlPasteValues
  15.             Sheets(sh.Name).Range("A1:D12").PasteSpecial xlPasteFormats
  16.             Sheets(sh.Name).Rows(1).RowHeight = 30
  17.              Sheets(sh.Name).Rows(5).RowHeight = 30
  18.               Sheets(sh.Name).Rows(9).RowHeight = 30
  19.             
  20.             x = x + 3: y = y + 3
  21.             Set sh = Nothing
  22.         Next
  23.     End With
  24. End Sub
複製代碼

TOP

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
5#
發表於 2015-9-28 13:20 | 只看該作者
回復 4# missbb

這樣試試
  1. Sub ex()
  2.     On Error Resume Next
  3.     With Sheets("總表")
  4.     x = 1: y = 3
  5.         ro = .Cells(Rows.Count, 1).End(xlUp).Row
  6.         For I = 1 To ro Step 12
  7.             Set sh = Sheets(x & "~" & y & "組")
  8.             If sh Is Nothing Then
  9.                 Set sh = Worksheets.Add(After:=Sheets(Sheets.Count))
  10.                 sh.Name = x & "~" & y & "組"
  11.             End If
  12.             .Range("a" & I & ":D" & I + 11).Copy
  13.             Sheets(sh.Name).Range("A1:D12").PasteSpecial xlPasteColumnWidths
  14.             Sheets(sh.Name).Range("A1:D12").PasteSpecial xlPasteValues
  15.             Sheets(sh.Name).Range("A1:D12").PasteSpecial xlPasteFormats
  16.             x = x + 3: y = y + 3
  17.             Set sh = Nothing
  18.         Next
  19.     End With
  20. End Sub
複製代碼

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
4#
發表於 2015-9-28 13:01 | 只看該作者
回復 2# lpk187

你好, 我想將總表的所有FORMAT, 包括欄寬及列高及FONT都COPY到每一張工作表, 因當中有條碼, 所以必須連FORMAT一併COPY, 已加下列代碼, 但只可COPY顏色, 請教是那一句欠了? 每3組移動新工作表20150929.rar (18.77 KB)
  1. Sub ex()
  2.     On Error Resume Next
  3.     With Sheets("總表")
  4.     x = 1: y = 3
  5.         ro = .Cells(Rows.Count, 1).End(xlUp).Row
  6.         For I = 1 To ro Step 12
  7.             Set sh = Sheets(x & "~" & y & "組")
  8.             If sh Is Nothing Then
  9.                 Set sh = Worksheets.Add(After:=Sheets(Sheets.Count))
  10.                 sh.Name = x & "~" & y & "組"
  11.             End If
  12.             .Range("a" & I & ":D" & I + 11).Copy Sheets(sh.Name).Range("A1")
  13.        [color=Red] .PasteSpecial xlPasteColumnWidths, False, False
  14.         .PasteSpecial xlPasteValues, , False, False
  15.         .PasteSpecial xlPasteFormats, , False, False[/color]
  16.             x = x + 3: y = y + 3
  17.             Set sh = Nothing
  18.         Next
  19.     End With
  20. End Sub
複製代碼

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
3#
發表於 2015-9-28 00:59 | 只看該作者

RE: 重複列數移動至新工作表

回復 2# lpk187

感謝指導 !

TOP

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
2#
發表於 2015-9-27 23:31 | 只看該作者
回復 1# missbb
  1. Sub ex()
  2.     On Error Resume Next
  3.     With Sheets("總表")
  4.     x = 1: y = 3
  5.         ro = .Cells(Rows.Count, 1).End(xlUp).Row
  6.         For I = 1 To ro Step 12
  7.             Set sh = Sheets(x & "~" & y & "組")
  8.             If sh Is Nothing Then
  9.                 Set sh = Worksheets.Add(After:=Sheets(Sheets.Count))
  10.                 sh.Name = x & "~" & y & "組"
  11.             End If
  12.             .Range("a" & I & ":D" & I + 11).Copy Sheets(sh.Name).Range("A1")
  13.             x = x + 3: y = y + 3
  14.             Set sh = Nothing
  15.         Next
  16.     End With
  17. End Sub
複製代碼

TOP

        靜思自在 : 每天無所事事，是人生的消費者，積極、有用才是人生的創造者。
返回列表 上一主題