[發問] 篩選後新增工作表

本帖最後由 missbb 於 2016-11-14 19:56 編輯

我試驗列最後一步了, 就是可以用部門或員工編號篩選, 在篩選部門是完全無問題, 但歸選員工編號, 又多出一張工作表, 想來想去想不通, 請大大幫忙:'(

VBA 申請表 20161114v1 (2).zip (19.07 KB)

Sub copytosheetok02()
'step select dept -> create appraisal form based on sheet result
With Sheets("list").Activate
Dim yn As Integer
yn = MsgBox(prompt:="如果篩選部門, 請按是", Buttons:=vbYesNo + vbQuestion)
If yn = vbYes Then
dept = InputBox("篩選部門:")
Range("a1").AutoFilter Field:=2, Criteria1:=dept
ActiveSheet.UsedRange.Select
Selection.copy
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "result"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Else
ID = InputBox("篩選編號:")
Range("a1").AutoFilter Field:=1, Criteria1:=ID
ActiveSheet.UsedRange.Select
Selection.copy
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "result"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End If
End With
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("result").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
[color=Red]Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheet[/color]s
'主要問題就出在這句了??????
For i = 4 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