返回列表 上一主題 發帖

[發問] 按名單及表格範本新增工作表

missbb

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

[發問] 按名單及表格範本新增工作表

老師好,有工作表是"名單", 另有工作表"表格範本", 請問如何用VBA寫出, 按"名單"新加工作表, 工作表名稱是"名單"第1行, 而工作表內容是"表格範本"??

有勞賜教 按名單及表格範本新增工作表.zip (18.14 KB)
收藏 分享

准提部林

帖子
2833 
主題
10 
精華
0 
積分
2889 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-16 
2#
發表於 2016-11-6 11:41 | 只看該作者
方案一：複製工作表或更新內容（如果人員工作表已存在）
  1. Sub 更新()
  2. Dim xR As Range, MySht As Worksheet, Sht As Worksheet, AR, i%
  3. Set MySht = ActiveSheet
  4. MySht.AutoFilterMode = False
  5. Application.ScreenUpdating = False
  6. For Each xR In Range(MySht.[A2], MySht.[A65536].End(xlUp))
  7.     If xR.Row = 1 Then Exit Sub
  8.     On Error Resume Next
  9.     Set Sht = Nothing:  Set Sht = Sheets(xR.Value)
  10.     On Error GoTo 0
  11.     If Sht Is Nothing Then
  12.        Sheets("表格範本").Copy After:=Sheets(Sheets.Count)
  13.        Set Sht = ActiveSheet:  Sht.Name = xR.Value
  14.        MySht.Select
  15.     End If
  16.     AR = Array("B3", "B4", "E3", "E4", "B6", "B7")
  17.     For i = 0 To UBound(AR)
  18.         Sht.Range(AR(i)) = ""
  19.         If xR(1, i + 1) <> "" Then Sht.Range(AR(i)) = xR(1, i + 1).Text
  20.     Next i
  21. Next
  22. End Sub
複製代碼
方案二：以一張表共用
  1. Sub 申請表()
  2. Dim xR As Range, AR
  3. Set xR = ActiveCell
  4. If xR.Row = 1 Or xR.Column > 1 Or xR.Value = "" Then
  5.     MsgBox "請在Ａ欄選擇要填入申請表的人員姓名！　": Exit Sub
  6. End If
  7. AR = Array("B3", "B4", "E3", "E4", "B6", "B7")
  8. With Sheets("申請表")
  9.      For i = 0 To UBound(AR)
  10.          .Range(AR(i)) = ""
  11.          If xR(1, i + 1) <> "" Then .Range(AR(i)).Value = xR(1, i + 1).Text
  12.      Next i
  13.      .Select
  14. End With
  15. End Sub
複製代碼
　
Xl0000027.rar (13.97 KB)
　
　

TOP

missbb

帖子
216 
主題
71 
精華
0 
積分
292 
點名
0  
作業系統
window xp 
軟體版本
2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-27 
最後登錄
2024-9-28 
3#
發表於 2016-11-7 23:50 | 只看該作者
多謝指導. 我自己思考了一個方法新增工作表.  但想用FILTER, 用INPUT BOX問要新增那一個部門的工作表, 如輸入ACC, 則只新增ACC的工作表. 這應如何做??? VBA 申請表V5.zip (20.32 KB)
  1. Sub copytosheetok2()

  3. Dim MyCell As Range, MyRange As Range

  5. Set MyRange = Sheets("list").Range("A2")
  6. Set MyRange = Range(MyRange, MyRange.End(xlDown))

  8.     Application.ScreenUpdating = False
  9.     Application.DisplayAlerts = False

  11. For Each MyCell In MyRange
  12.    
  13.    
  14. Sheets("form").Copy After:=Sheets(Sheets.Count) 'Create a new worksheet

  16. Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets

  18. For i = 3 To Sheets.Count
  19.         With Sheets(i).Range("A1:E7")
  20.                  .Value = .Value
  21.         End With
  22.    
  23.           With Sheets(i).Range("A10:B11")
  24.                  .Value = .Value
  25.         End With
  26.     Next i

  28. Next MyCell
  29.    Application.ScreenUpdating = True
  30.     Application.DisplayAlerts = True


  33. End Sub
複製代碼
回復 2# 准提部林

TOP

missbb

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

可如何加入下列CODE, FILTER後才新增工作表:
Input box : 輸入部門
例如:ACC 或全部
sheets("list").Select
ActiveSheet.Range("$A$1:$Z$1048576").AutoFilter Field:=2, Criteria1:="ACC"
只新增部門是ACC的工作表
.......不懂如何接下去.....

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
5#
發表於 2016-11-8 09:29 | 只看該作者
本帖最後由 Kubi 於 2016-11-8 09:34 編輯

回復 4# missbb
改用滑鼠點選B欄某個部門後，再按執行鈕來新增該部門的工作表，反之，則新增全部門工作表。
VBA 申請表V5.rar (23.9 KB)

TOP

missbb

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

但一按HRA只印出一份HRA, 可否按HRA, 所有HRA會印出?

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
7#
發表於 2016-11-9 21:30 | 只看該作者
回復 6# missbb
底下的程式碼只印出你所選的某部門內所有人員資料，這會與上面樓層(述求：新增工作表)的作業完全不同。
還有，若要印出所有部門資料，則請自行練習修改程式碼。
VBA 申請表V5-Print.rar (24.17 KB)

TOP

missbb

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

有勞赐教

TOP

Farnsworth

帖子
50 
主題
9 
精華
0 
積分
65 
點名
1  
作業系統
WIN10 
軟體版本
OFFICE2016 
閱讀權限
20 
註冊時間
2015-6-2 
最後登錄
2024-11-1 
9#
發表於 2016-11-10 10:13 | 只看該作者
以上各位思路都非常好，关键是写VBA代码的时候考虑简化和代码最优化，感谢分享各位分享经验及技术代码。

TOP

missbb

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

你好, 我又試了篩選LIST的部門是HRA, 再COPY 只有部門是HRA的工作表, 但又是全部都COPY出工作表(HRA, ACC) VBA 申請表V1 original (2).zip (22.91 KB) , 請問下列CODE有甚麼欠缺?
Sub copytosheetok3()


Dim Rng As Range        
Dim theRow As Range     
Dim theArea As Range      
    With Sheets("list")      
        Set Rng = .UsedRange   
        Rng.AutoFilter Field:=2, Criteria1:="HRA"     '¿z¿ï
            Set Rng = Rng.Resize(Rng.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible)
    End With

Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("list").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

For Each MyCell In MyRange
        
Sheets("form").Copy after:=Sheets(Sheets.Count) 'Create a new worksheet

Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets

For i = 3 To Sheets.Count
        With Sheets(i).Range("A1:E7")
                 .Value = .Value
        End With
   
          With Sheets(i).Range("A10:B11")
                 .Value = .Value
        End With
    Next i

Next MyCell
   Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
返回列表 上一主題