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

missbb

想請教VBA做法如下:

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

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

下載次數: 5

2015-9-27 22:37

missbb

回復 2# lpk187

感謝指導 !

missbb

回復 2# lpk187

你好, 我想將總表的所有FORMAT, 包括欄寬及列高及FONT都COPY到每一張工作表, 因當中有條碼, 所以必須連FORMAT一併COPY, 已加下列代碼, 但只可COPY顏色, 請教是那一句欠了? 每3組移動新工作表20150929.rar (18.77 KB)

下載次數: 7

2015-9-28 13:00

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

複製代碼

missbb

回復 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

複製代碼