彰化一整天的論壇

 找回密碼
 立即註冊
查看: 1603|回復: 11

如何一次依序產生多個指定名稱的格式工作表在活頁簿

[複製鏈接]
發表於 2020-12-30 08:50:21 | 顯示全部樓層 |閱讀模式
本帖最後由 luckysan 於 2020-12-30 19:29 編輯

呈先前的發文帖子的內容
1. 請問如何設定VBA自動判斷 [複製工作表某區間的資料]
2.如何結合兩個功能VBA與快速刪除不須要的工作表

我想請教,如果我要反過來透過索引頁籤的客戶國別代號來依照順序新增固定格式的工作表,
請見附擋"客代號一次建立多個工作表",
索引頁籤有客戶代號,客戶公司名稱,備註
且每個工作表的表頭要一樣, 但在對應欄位的
客戶名稱. 備註. 客戶代號  也要一併產生在對應的工作表的表頭欄位上,
如圖片表頭

請問在VBA中要如何一次產生有指定名稱與指定格式應有內容的工作表?
以下是一次快速新增客戶名的工作表名稱的VBA,但是我要套用格式, 請問這樣要怎麼修改好?
  1. Sub SheetAdd()

  2. Dim i As Long

  3. Sheets.Add After:=Sheets(Sheets.Count), Count:=Sheets(1).Range("A" & Rows.Count - 1).End(xlUp).Row - 1

  4. For i = 3 To Sheets.Count

  5. Sheets(i).Name = Sheets(1).Cells(i, 1).Value

  6. Next

  7. MsgBox "創建工作表完成!"

  8. End Sub
複製代碼
但這個代碼,最後會多一個部需要的Sheet工作表

表頭.png
1609223126(1).png

客代號一次建立多個工作表-修1.xlsm

470.01 KB, 下載次數: 1

售價: 1 金錢  [記錄]  [購買]

回復

使用道具 舉報

發表於 2020-12-30 11:38:33 | 顯示全部樓層
您可以用錄製巨集的方法,看它產生的程式碼,再利用迴圈執行全部。
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-30 13:16:12 | 顯示全部樓層
imingho 發表於 2020-12-30 11:38
您可以用錄製巨集的方法,看它產生的程式碼,再利用迴圈執行全部。

目前錄製是這樣,但有錯誤


  1. Sub Macro1()
  2. '
  3. ' Macro1 Macro
  4. '

  5. '
  6.     Range("F1").Select
  7.     Sheets("索引頁籤").Select
  8.     ActiveCell.FormulaR1C1 = "台C005"
  9.     With ActiveCell.Characters(Start:=1, Length:=0).Font
  10.         .Name = "Times New Roman"
  11.         .FontStyle = "標準"
  12.         .Size = 12
  13.         .Strikethrough = False
  14.         .Superscript = False
  15.         .Subscript = False
  16.         .OutlineFont = False
  17.         .Shadow = False
  18.         .Underline = xlUnderlineStyleNone
  19.         .ThemeColor = xlThemeColorLight1
  20.         .TintAndShade = 0
  21.         .ThemeFont = xlThemeFontNone
  22.     End With
  23.     With ActiveCell.Characters(Start:=1, Length:=1).Font
  24.         .Name = "細明體"
  25.         .FontStyle = "標準"
  26.         .Size = 12
  27.         .Strikethrough = False
  28.         .Superscript = False
  29.         .Subscript = False
  30.         .OutlineFont = False
  31.         .Shadow = False
  32.         .Underline = xlUnderlineStyleNone
  33.         .ThemeColor = xlThemeColorLight1
  34.         .TintAndShade = 0
  35.         .ThemeFont = xlThemeFontNone
  36.     End With
  37.     With ActiveCell.Characters(Start:=2, Length:=4).Font
  38.         .Name = "Times New Roman"
  39.         .FontStyle = "標準"
  40.         .Size = 12
  41.         .Strikethrough = False
  42.         .Superscript = False
  43.         .Subscript = False
  44.         .OutlineFont = False
  45.         .Shadow = False
  46.         .Underline = xlUnderlineStyleNone
  47.         .ThemeColor = xlThemeColorLight1
  48.         .TintAndShade = 0
  49.         .ThemeFont = xlThemeFontNone
  50.     End With
  51.     Sheets("格式").Select
  52.     ActiveCell.Offset(0, 15).Range("A1").Select
  53.     ActiveCell.FormulaR1C1 = "台C005"
  54.     Sheets("索引頁籤").Select
  55.     ActiveCell.Offset(0, 1).Range("A1").Select
  56.     ActiveCell.FormulaR1C1 = "高興股份有限公司"
  57.     Sheets("格式").Select
  58.     ActiveCell.Offset(0, -15).Range("A1").Select
  59.     ActiveCell.FormulaR1C1 = "高興股份有限公司"
  60.     Sheets("索引頁籤").Select
  61.     ActiveCell.Offset(0, 3).Range("A1").Select
  62.     ActiveCell.FormulaR1C1 = "每月過25號後開下一個月發票"
  63.     Sheets("格式").Select
  64.     ActiveCell.Offset(0, 8).Range("A1").Select
  65.     ActiveCell.FormulaR1C1 = "每月過25號後開下一個月發票"
  66.     ActiveCell.Offset(1, 0).Range("A1").Select
  67.     ActiveWindow.ScrollColumn = 3
  68.     ActiveWindow.ScrollColumn = 4
  69.     ActiveWindow.ScrollColumn = 5
  70.     ActiveWindow.ScrollColumn = 6
  71.     ActiveWindow.ScrollColumn = 7
  72.     ActiveWindow.ScrollColumn = 8
  73.     Sheets("格式").Select
  74.     Sheets("格式").Copy After:=Sheets(2)
  75.     Sheets("格式 (2)").Select
  76.     Sheets("格式 (2)").Name = "格式 (2)"
  77.     Range("U1").Select
  78.     ActiveCell.FormulaR1C1 = "台C005"
  79.     Sheets("格式 (2)").Select
  80.     Sheets("格式 (2)").Name = "台C005"
  81. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

發表於 2020-12-30 14:38:48 | 顯示全部樓層
imingho 發表於 2020-12-30 11:38
您可以用錄製巨集的方法,看它產生的程式碼,再利用迴圈執行全部。

請上傳您有寫程式的版本.
excel20201230_a.jpg

1.有命名範圍,不能用複製工作表

excel20201230_b.jpg

2.找不到您的程式碼


回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-30 15:26:47 | 顯示全部樓層
imingho 發表於 2020-12-30 14:38
請上傳您有寫程式的版本.

1.有命名範圍,不能用複製工作表

檔案已更新. 有錄製的巨集Macro1
回復 支持 反對

使用道具 舉報

發表於 2020-12-30 15:52:29 | 顯示全部樓層
luckysan 發表於 2020-12-30 15:26
檔案已更新. 有錄製的巨集Macro1
  1. Sub SheetAdd_修改過()

  2.     Dim i As Long
  3.    
  4.     Dim n As Long
  5.    
  6.     n = Sheets(1).Range("A" & Rows.Count - 1).End(xlUp).Row - 1
  7.    
  8.             
  9.     For i = 3 To n
  10.         
  11.         Sheets("格式").Copy After:=Sheets(Sheets.Count)
  12.         
  13.         Sheets(Sheets.Count).Name = Sheets(1).Cells(i, 1).Value
  14.         
  15.         Sheets(Sheets.Count).Range("F1").Value = Sheets(1).Cells(i, 2).Value
  16.         
  17.         Sheets(Sheets.Count).Range("U1").Value = Sheets(1).Cells(i, 1).Value
  18.         
  19.         Sheets(Sheets.Count).Range("N1").Value = Sheets(1).Cells(i, 5).Value
  20.         
  21.    
  22.     Next
  23.    
  24.     MsgBox "創建工作表完成!"

  25. End Sub
複製代碼

客代號一次建立多個工作表-修.xlsm

29.03 KB, 下載次數: 1

售價: 1 金錢  [記錄]

回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-30 19:28:18 | 顯示全部樓層

imingho大大,可以了,
但是如何再加入讓索引頁籤與每個工作表產生超連結
本來是以這個公式來產生超連結:
A2儲存格打
=IFERROR(HYPERLINK("# '"&INDEX(X,ROW())&"'!A1",INDEX(X,ROW())),"----")
往下拉,會拉出每個工作表名稱並自動產生超連結

另外在索引頁籤的C3儲存格的公式=GetSheetPageCount(A3)
卻好像不能計算各工作表占幾頁了

請見上方檔案"客代號一次建立多個工作表-修1"
回復 支持 反對

使用道具 舉報

發表於 2020-12-31 14:11:22 | 顯示全部樓層
luckysan 發表於 2020-12-30 19:28
imingho大大,可以了,
但是如何再加入讓索引頁籤與每個工作表產生超連結
本來是以這個公式來產生超連結:

您的GetSheetPageCount的副程式不見了.當然不會出來.
GetSheetPage_01.jpg

回復 支持 反對

使用道具 舉報

發表於 2020-12-31 14:19:41 | 顯示全部樓層
imingho 發表於 2020-12-31 14:11
您的GetSheetPageCount的副程式不見了.當然不會出來.


GetSheetPage_02.jpg

1.將副程式加回的畫面.



客代號一次建立多個工作表-修1.xlsm

458.1 KB, 下載次數: 1

售價: 1 金錢  [記錄]

回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-31 15:17:17 | 顯示全部樓層
imingho 發表於 2020-12-31 14:19
1.將副程式加回的畫面.

有的,但索引頁籤如何超連結每個對應客戶工作表?
如下圖片
超連結對應工作表
若使用本來的公式去拉的話,則旁邊的資料都會跑掉
=IFERROR(HYPERLINK("# '"&INDEX(X,ROW())&"'!A1",INDEX(X,ROW())),"----")

變成下方這樣,且旁邊的Getsheetpagecount也無法計數
無法產生連結各工作表
回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)

GMT+8, 2021-9-21 00:32 , Processed in 0.145654 second(s), 20 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回復 返回頂部 返回列表