Board logo

標題: [發問] 按名單及表格範本新增工作表 [打印本頁]
作者: missbb    時間: 2016-11-6 00:03     標題: 按名單及表格範本新增工作表

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

有勞賜教[attach]25730[/attach]
作者: 准提部林    時間: 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
複製代碼
　
[attach]25738[/attach]
　
　
作者: missbb    時間: 2016-11-7 23:50

多謝指導. 我自己思考了一個方法新增工作表.  但想用FILTER, 用INPUT BOX問要新增那一個部門的工作表, 如輸入ACC, 則只新增ACC的工作表. 這應如何做???[attach]25748[/attach]
  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# 准提部林
作者: missbb    時間: 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的工作表
.......不懂如何接下去.....
作者: Kubi    時間: 2016-11-8 09:29

本帖最後由 Kubi 於 2016-11-8 09:34 編輯

回復 4# missbb
改用滑鼠點選B欄某個部門後，再按執行鈕來新增該部門的工作表，反之，則新增全部門工作表。
[attach]25752[/attach]
作者: missbb    時間: 2016-11-8 22:16

回復 5# Kubi

但一按HRA只印出一份HRA, 可否按HRA, 所有HRA會印出?
作者: Kubi    時間: 2016-11-9 21:30

回復 6# missbb
底下的程式碼只印出你所選的某部門內所有人員資料，這會與上面樓層(述求：新增工作表)的作業完全不同。
還有，若要印出所有部門資料，則請自行練習修改程式碼。
[attach]25757[/attach]
作者: missbb    時間: 2016-11-9 22:19

回復 7# Kubi

有勞赐教
作者: Farnsworth    時間: 2016-11-10 10:13

以上各位思路都非常好，关键是写VBA代码的时候考虑简化和代码最优化，感谢分享各位分享经验及技术代码。
作者: missbb    時間: 2016-11-10 22:31

回復 7# Kubi

你好, 我又試了篩選LIST的部門是HRA, 再COPY 只有部門是HRA的工作表, 但又是全部都COPY出工作表(HRA, ACC)[attach]25759[/attach][attach]25759[/attach][attach]25759[/attach], 請問下列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



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