返回列表 上一主題 發帖

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

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)
收藏 分享

missbb

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

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

回復 2# lpk187

感謝指導 !

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
3#
發表於 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 
4#
發表於 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

        靜思自在 : 犯錯出懺悔心，才能清淨無煩惱。
返回列表 上一主題