Board logo

標題: [發問] 重複列數移動至新工作表 [打印本頁]
作者: missbb    時間: 2015-9-27 22:37     標題: 重複列數移動至新工作表

想請教VBA做法如下:

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

求教![attach]22096[/attach]
作者: lpk187    時間: 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
複製代碼
作者: missbb    時間: 2015-9-28 00:59     標題: RE: 重複列數移動至新工作表

回復 2# lpk187

感謝指導 !
作者: missbb    時間: 2015-9-28 13:01

回復 2# lpk187

你好, 我想將總表的所有FORMAT, 包括欄寬及列高及FONT都COPY到每一張工作表, 因當中有條碼, 所以必須連FORMAT一併COPY, 已加下列代碼, 但只可COPY顏色, 請教是那一句欠了?[attach]22102[/attach]
  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
複製代碼
作者: lpk187    時間: 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
複製代碼
作者: missbb    時間: 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
複製代碼
作者: 准提部林    時間: 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)，
過後還是要恢復偵錯功能，否則遇錯誤無法檢知，對資料的正確性有風險！！！
作者: kerochen    時間: 2015-10-1 21:19

感謝好技巧. 雖然不是我發問的. 但受教了. 這是個很實用的例子.



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)