Board logo

標題: 資料依條件 分SHEET [打印本頁]
作者: hugh0620    時間: 2011-3-22 12:41     標題: 資料依條件 分SHEET

Dear 大大們~
        附件是幫學弟妹完成的檔案
     可以達到需求 但有一個缺點就是若再按一次"匯出"的按鈕~ 會有[標籤名稱]一樣~ 產生錯誤
     整個撰寫上也不是很好~
        其條件很簡單,主要是
      by Item_ID 為分頁條件
         另外兩個
         by Point_OFFSET
         by Data_Date
         在同一天中,將Point_OFFSET (共三站)的資料直列放在一起

        想請個位大大~ 是否有更好的寫法~ 供小弟參考學習
      [attach]5090[/attach]
作者: GBKEE    時間: 2011-3-22 15:12

本帖最後由 GBKEE 於 2011-3-22 15:17 編輯

回復 1# hugh0620
方法一  刪掉工作表
  1. Sub Ex()
  2.     Dim Sh As Worksheet
  3.     Application.DisplayAlerts = False
  4.     For Each Sh In Sheets
  5.         If Sh.Name <> "Data匯整" And Sh.Name <> "原始Data" Then Sh.Delete
  6.     Next
  7.     Application.DisplayAlerts = True
  8. End Sub
複製代碼
方法二 除錯
  1. Dim N As Integer
  2. A = Application.CountA(Sheet2.[A3:A65536])  'A統計出需要跑幾個Sheet
  3. On Error GoTo Sheet_Add      '有錯誤到 行號     Sheet_Add
  4. For N = 1 To A
  5.     'Sheets.Add AFTER:=Worksheets(N + 1)           '新增sheet
  6.         Sheets("" & N).Activate                      '''
  7.         Sheets("" & N).Cells.Clear                  '''
  8.         ActiveSheet.Range("A1") = Sheet2.Range("B2")
  9.         ActiveSheet.Range("B1") = Sheet2.Cells(2 + N, 1)
  10.         ActiveSheet.Range("B2") = Sheet2.Range("E2")
  11.   '
  12.   '
  13.   '
  14.     Do
  15.    
  16.     Loop

  18.     H = 0
  19.     Z = 0
  20.     ActiveSheet.Rows("2:2").Select
  21.     Selection.NumberFormatLocal = "yyyy/m/d"
  22. Next
  23. Exit Sub
  24. Sheet_Add:              '行號
  25. With Sheets.Add(AFTER:=Worksheets(N + 1))            '新增sheet
  26.     .Name = Sheet2.Cells(2 + N, 1)    '標籤名稱
  27. End With
  28. Resume Next                  '返回錯誤處
  29. End Sub
複製代碼
Macro5()的簡化
  1. Sub Macro5() '複製貼上Data匯整
  2.     Sheet1.Range("A2").CurrentRegion.Copy Sheet2.Range("B2")
  3. End Sub
複製代碼
作者: hugh0620    時間: 2011-3-22 18:45

本帖最後由 hugh0620 於 2011-3-22 18:53 編輯

感謝大大GBKEE 的回復唷~ 加上一個刪除鈕~ 可以結省掉刪除sheet的動作~
    複製的部份~ 也簡化~ 也能夠理解~
    使整個更完整操作上更簡化也簡便許多~

    但是大大~ 除錯的部份~ 有測試過~ 但產生錯誤唷~
    造成Data匯整的sheet 資料被覆蓋
作者: GBKEE    時間: 2011-3-22 19:46

回復 3# hugh0620
請傳檔上來看看
作者: hugh0620    時間: 2011-3-23 09:07

回復 4# GBKEE


    大大~ 執行的結果會卡在產生第21 Sheet 時~ 會有錯誤
   錯誤產生時~ 值行到第26行指令
   26.    .Name = Sheet2.Cells(2 + N, 1)    '標籤名稱
   如附件
   [attach]5101[/attach]
作者: GBKEE    時間: 2011-3-23 10:09

本帖最後由 GBKEE 於 2011-3-23 11:17 編輯

回復 5# hugh0620
Data匯整 的工作表序號不連續  18,19,21,22 缺 20
改為 Sheet2.Cells(2 + N, 1).Text
For N = 1 To A
  'Sheets.Add AFTER:=Worksheets(N + 1)           '新增sheet
  Sheets(Sheet2.Cells(2 + N, 1).Text).Activate                      '''
  Sheets(Sheet2.Cells(2 + N, 1).Text).Cells.Clear
修改你的程式如下
  1. Private Sub CommandButton1_Click()
  2.     Dim N As Integer, E
  3.     CommandButton2_Click
  4.     With Sheets("Data匯整")
  5.         Sheets("原始Data").Range("A2").CurrentRegion.Copy .Range("B2")
  6.      '=====排序====
  7.         .Range("B3").End(xlToRight).End(xlDown).Sort Key1:=.Range("B3"), _
  8. Order1:=xlAscending, Key2:=.Range("C3"), Order2:=xlAscending, Key3:=.Range("E3"), Order3:=xlAscending, Header:=xlYes
  9. '=====排序====
  10. '=====進階篩選====
  11. '    .Range("B2").Select
  12. '   Range(Selection, Selection.End(xlDown)).Select
  13.     .Range("B2:B256").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range( _
  14.         "A2"), Unique:=True
  15. '=====進階篩選====
  16.     End With
  17. On Error GoTo Sheet_Add      '有錯誤到 行號     Sheet_Add
  18. A = Application.CountA(Sheet2.[A3:A65536])  'A統計出需要跑幾個Sheet
  19. For N = 1 To A
  20.     Sheets(Sheet2.Cells(2 + N, 1).Text).Select
  21.     With ActiveSheet
  22.         .Cells.Clear                  '''
  23.         .Range("A1") = Sheets("Data匯整").Range("B2")
  24.         .Range("B1") = Sheets("Data匯整").Cells(2 + N, 1)
  25.         .Range("B2") = Sheets("Data匯整").Range("E2")
  26.         For Each E In Array(1, 97, 193)
  27.             With .Cells(Rows.Count, 1).End(xlUp).Offset(1)
  28.                 .Cells(1) = "POINT_1"
  29.                 .Cells(2) = "POINT_2"
  30.                 .Cells.Resize(2).AutoFill .Cells.Resize(96)
  31.                 .Cells(1, 2).Resize(96) = E
  32.             End With
  33.         Next
  34.     End With
  35.     Do Until Sheet2.Cells(3 + H, 2) = ""
  36.         If Sheet2.Cells(3 + H, 2) = Sheet2.Cells(2 + N, 1) Then
  37.             If ActiveSheet.Cells(2, 2 + Z) = Sheet2.Cells(3 + H, 3) Then
  38.                 Select Case Sheet2.Cells(3 + H, 5)
  39.                     Case 1
  40.                         For X = 1 To 96
  41.                         ActiveSheet.Cells(2 + X, 2 + Z) = Sheet2.Cells(3 + H, 5 + X)
  42.                         Next
  43.                     Case 97
  44.                         For X = 1 To 96
  45.                         ActiveSheet.Cells(98 + X, 2 + Z) = Sheet2.Cells(3 + H, 5 + X)
  46.                         Next
  47.                     Case 193
  48.                         For X = 1 To 96
  49.                         ActiveSheet.Cells(194 + X, 2 + Z) = Sheet2.Cells(3 + H, 5 + X)
  50.                         Next
  51.                 End Select
  52.             Else
  53.                 Z = Z + 1
  54.                 ActiveSheet.Cells(2, 2 + Z) = Sheet2.Cells(3 + H, 3)
  55.                 Select Case Sheet2.Cells(3 + H, 5)
  56.                     Case 1
  57.                         For X = 1 To 96
  58.                         ActiveSheet.Cells(2 + X, 2 + Z) = Sheet2.Cells(3 + H, 5 + X)
  59.                         Next
  60.                     Case 97
  61.                         For X = 1 To 96
  62.                         ActiveSheet.Cells(98 + X, 2 + Z) = Sheet2.Cells(3 + H, 5 + X)
  63.                         Next
  64.                     Case 193
  65.                         For X = 1 To 96
  66.                         ActiveSheet.Cells(194 + X, 2 + Z) = Sheet2.Cells(3 + H, 5 + X)
  67.                         Next
  68.                 End Select
  69.             End If
  70.         End If
  71.     H = H + 1
  72.     Loop
  73.     H = 0
  74.     Z = 0
  75.     'ActiveSheet.Rows ("2:2")
  76.     'Selection.NumberFormatLocal = "yyyy/m/d"
  77.     ActiveSheet.Rows("2:2").NumberFormatLocal = "yyyy/m/d"
  78. Next
  79. Exit Sub
  80. Sheet_Add:              '行號
  81. If Err <> 9 Then
  82.     MsgBox "錯誤值 " & Err & "   請檢查錯誤 !!!"
  83.     Exit Sub
  84. End If
  85. With Sheets.Add(AFTER:=Worksheets(N + 1))            '新增sheet
  86.     .Name = Sheet2.Cells(2 + N, 1)    '標籤名稱
  87. End With
  88. Resume Next                  '返回錯誤處
  89. End Sub
複製代碼




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