Board logo

標題: [發問] 篩選後新增工作表 [打印本頁]
作者: missbb    時間: 2016-11-14 19:55     標題: 篩選後新增工作表

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

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

[attach]25801[/attach]
  1. Sub copytosheetok02()
  2. 'step select dept -> create appraisal form based on sheet result

  4. With Sheets("list").Activate

  6. Dim yn As Integer

  8. yn = MsgBox(prompt:="如果篩選部門, 請按是", Buttons:=vbYesNo + vbQuestion)
  9. If yn = vbYes Then

  11.     dept = InputBox("篩選部門:")
  12.     Range("a1").AutoFilter Field:=2, Criteria1:=dept
  13.     ActiveSheet.UsedRange.Select
  14.     Selection.copy
  15.     Sheets.Add After:=Sheets(Sheets.Count)
  16.     Sheets(Sheets.Count).Name = "result"
  17.     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
  18.         xlNone, SkipBlanks:=False, Transpose:=False
  19.         
  20. Else
  21.     ID = InputBox("篩選編號:")
  22.     Range("a1").AutoFilter Field:=1, Criteria1:=ID
  23.     ActiveSheet.UsedRange.Select
  24.     Selection.copy
  25.     Sheets.Add After:=Sheets(Sheets.Count)
  26.     Sheets(Sheets.Count).Name = "result"
  27.     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
  28.         xlNone, SkipBlanks:=False, Transpose:=False

  30. End If

  32. End With

  34. Dim MyCell As Range, MyRange As Range

  36. Set MyRange = Sheets("result").Range("A2")
  37. Set MyRange = Range(MyRange, MyRange.End(xlDown))

  39.     Application.ScreenUpdating = False
  40.     Application.DisplayAlerts = False

  42. For Each MyCell In MyRange
  43. Sheets("form").copy After:=Sheets(Sheets.Count) 'Create a new worksheet
  44. [color=Red]Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheet[/color]s
  45. '主要問題就出在這句了??????

  47. For i = 4 To Sheets.Count
  48.         With Sheets(i).Range("A1:E7")
  49.                  .Value = .Value
  50.         End With
  51.    
  52.           With Sheets(i).Range("A10:B11")
  53.                  .Value = .Value
  54.         End With
  55.     Next i
  56. Next MyCell

  58.     Application.ScreenUpdating = True
  59.     Application.DisplayAlerts = True

  61. End Sub
複製代碼
作者: 葉國洲    時間: 2016-11-15 18:44

37行改為
  1. Set MyRange = Sheets("result").Range("A2")
  2. If MyRange.Count > 1 Then Set MyRange = Range(MyRange, MyRange.End(xlDown))
複製代碼
作者: 葉國洲    時間: 2016-11-15 18:58

抱歉,樓上是錯的37行是
  1. If yn = vbYes Then Set MyRange = Range(MyRange, MyRange.End(xlDown))
複製代碼
作者: missbb    時間: 2016-11-16 14:19     標題: RE: 篩選後新增工作表

回復 3# 葉國洲

感謝!:lol



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