Board logo

標題: [發問] 請問VBA如何迴圈選取已篩選的資料複製到新工作表上的特定範圍 [打印本頁]
作者: lunboy    時間: 2018-8-17 00:08     標題: 請問VBA如何迴圈選取已篩選的資料複製到新工作表上的特定範圍

如題, 我想使用VBA去迴圈選取已篩選的資料複製到新工作表上的特定範圍及自動開新一行。
我嘗試錄製了巨集及修改了少許,但不成功。

VBA的 步驟:
    1.按下在SHEET “VBA” 上的 In out record 7 days按扭
    2.當按下制後,會選擇SHEET “AT”
    3.在SHEET”AT”上, 由A6拉到AD6, 之後按篩選
    4.之後在F6進行日期篩選,
    5.把SHEET “In out record” 複製一張新SHEET 叫 “In out record 2”
    6.把”In out record 2”複製一張新SHEET叫”In out record_AT”
    7.把剛才在SHEET “AT”上篩選得出的資料複製
    8.在SHEET ”In out record_AT” set C12 的VALUE 是AT
    9.在SHEET” In out record_AT” 的B17 貼上剛才所複製的資料,每複製一次,開新一行,  在新一行上繼續複製及不夠位自動INSERT新一行
    重複步驟4至8, 做7次(今日前3天到今日後3天,共7天)

我現在做到了1至8,但步驟9做了一次還可以,之後再複製就會覆蓋之前的資料
請問如何修改? 麻煩指導，感謝。

Code:
  1. Private Sub CommandButton17_Click()
  2. Set copysheet = ThisWorkbook.Sheets("In out record")
  3. copysheet.Activate
  4. copysheet.Range("A1:O49").Select
  5.     Selection.Copy
  6.     Sheets.Add After:=Sheets(Sheets.Count)
  7.     Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
  8.         SkipBlanks:=False, Transpose:=False
  9.     ActiveSheet.Paste
  10.     ActiveSheet.Name = "In out record 2"
  11. Set copysheet2 = ThisWorkbook.Sheets("In out record 2")

  13. copysheet2.Copy After:=Sheets("In out record 2")
  14. Set ATworksheet = Sheets(Sheets("In out record 2").Index + 1)
  15. ATworksheet.Name = "In out record_AT"

  17. Set wSheetStart = ThisWorkbook.Sheets("AT")
  18. wSheetStart.Activate
  19. wSheetStart.AutoFilterMode = False
  20. ActiveSheet.Range("A6:AC6").AutoFilter Field:=6, Criteria1:=">=" & DateSerial(Year(Now - 3), Month(Now - 3), Day(Now - 3)), Operator:=xlAnd, Criteria2:="<=" & DateSerial(Year(Now - 3), Month(Now - 3), Day(Now - 3))
  21. If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then

  23. Worksheets("AT").Range("B7").Select
  24.     Worksheets("AT").Range("B7:N7").Select
  25.     Worksheets("AT").Range(Selection, Selection.End(xlDown)).Select
  26.     Selection.Copy
  27. ATworksheet.Activate
  28. ATworksheet.Range("B17").PasteSpecial

  30.   ATworksheet.Range("C12").Value = "AT"
  31.    
  32.     Set btn = ActiveSheet.Buttons.Add(477, 177, 40, 40)
  33.     With btn
  34.     .OnAction = "btnS"
  35.     .Caption = "Save As"
  36.     .Name = "Save As"
  37.     Application.ScreenUpdating = True
  38.     End With
  39.    
  40.     ATworksheet.Range("B21").Select
  41.    
  42.     wSheetStart.Activate
  43. ActiveSheet.Range("A6:AC6").AutoFilter Field:=6, Criteria1:=">=" & DateSerial(Year(Now - 2), Month(Now - 2), Day(Now - 2)), Operator:=xlAnd, Criteria2:="<=" & DateSerial(Year(Now - 2), Month(Now - 2), Day(Now - 2))
  44. If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
  45. Worksheets("AT").Range("B7").Select

  47.     Worksheets("AT").Range("B7:N7").Select

  49.     Worksheets("AT").Range(Selection, Selection.End(xlDown)).Select
  50.     Selection.Copy
  51. ATworksheet.Activate
  52. ATworksheet.Range("B17").End(xlUp).Offset(1).PasteSpecial

  54. wSheetStart.Activate
  55. ActiveSheet.Range("A6:AC6").AutoFilter Field:=6, Criteria1:=">=" & DateSerial(Year(Now - 1), Month(Now - 1), Day(Now - 1)), Operator:=xlAnd, Criteria2:="<=" & DateSerial(Year(Now - 1), Month(Now - 1), Day(Now - 1))
  56. If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
  57. Worksheets("AT").Range("B7").Select

  59.     Worksheets("AT").Range("B7:N7").Select
  60.     Worksheets("AT").Range(Selection, Selection.End(xlDown)).Select
  61.     Selection.Copy
  62. ATworksheet.Activate
  63. ATworksheet.Range("B17").End(xlUp).Offset(3).PasteSpecial

  65. wSheetStart.Activate
  66. ActiveSheet.Range("A6:AC6").AutoFilter Field:=6, Criteria1:=">=" & DateSerial(Year(Now), Month(Now), Day(Now)), Operator:=xlAnd, Criteria2:="<=" & DateSerial(Year(Now), Month(Now), Day(Now))
  67. If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
  68. Worksheets("AT").Range("B7").Select

  70.     Worksheets("AT").Range("B7:N7").Select
  71.     Worksheets("AT").Range(Selection, Selection.End(xlDown)).Select
  72.     Selection.Copy
  73. ATworksheet.Activate
  74. ATworksheet.Range("B17").End(xlUp).Offset(5).PasteSpecial

  76. wSheetStart.Activate
  77. ActiveSheet.Range("A6:AC6").AutoFilter Field:=6, Criteria1:=">=" & DateSerial(Year(Now + 1), Month(Now + 1), Day(Now + 1)), Operator:=xlAnd, Criteria2:="<=" & DateSerial(Year(Now + 1), Month(Now + 1), Day(Now + 1))
  78. If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
  79. Worksheets("AT").Range("B7").Select
  80.     Worksheets("AT").Range("B7:N7").Select
  81.     Worksheets("AT").Range(Selection, Selection.End(xlDown)).Select
  82.     Selection.Copy
  83. ATworksheet.Activate
  84. ATworksheet.Range("B17").End(xlUp).Offset(7).PasteSpecial

  86. wSheetStart.Activate
  87. ActiveSheet.Range("A6:AC6").AutoFilter Field:=6, Criteria1:=">=" & DateSerial(Year(Now + 2), Month(Now + 2), Day(Now + 2)), Operator:=xlAnd, Criteria2:="<=" & DateSerial(Year(Now + 2), Month(Now + 2), Day(Now + 2))
  88. If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
  89. Worksheets("AT").Range("B7").Select
  90.     Worksheets("AT").Range("B7:N7").Select
  91.     Worksheets("AT").Range(Selection, Selection.End(xlDown)).Select
  92.     Selection.Copy
  93. ATworksheet.Activate
  94. ATworksheet.Range("B17").End(xlUp).Offset(9).PasteSpecial

  96. wSheetStart.Activate
  97. ActiveSheet.Range("A6:AC6").AutoFilter Field:=6, Criteria1:=">=" & DateSerial(Year(Now + 3), Month(Now + 3), Day(Now + 3)), Operator:=xlAnd, Criteria2:="<=" & DateSerial(Year(Now + 3), Month(Now + 3), Day(Now + 3))
  98. If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
  99. Worksheets("AT").Range("B7").Select
  100.     Worksheets("AT").Range("B7:N7").Select
  101.     Worksheets("AT").Range(Selection, Selection.End(xlDown)).Select
  102.     Selection.Copy
  103. ATworksheet.Activate
  104. ATworksheet.Range("B17").End(xlUp).Offset(11).PasteSpecial

  106. End If
  107. End If
  108. End If
  109. End If
  110. End If
  111. End If
  112. End If
  113. End Sub
  114.    
複製代碼
作者: a5007185    時間: 2018-8-17 01:57

有附檔會更好



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