資料依條件 分SHEET

hugh0620

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

        想請個位大大~ 是否有更好的寫法~ 供小弟參考學習
       Data_VBA完成版.rar (81.29 KB)

下載次數: 20

2011-3-22 12:38

GBKEE

回復 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
    
17. 
    
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

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

    但是大大~ 除錯的部份~ 有測試過~ 但產生錯誤唷~
    造成Data匯整的sheet 資料被覆蓋

GBKEE

回復 3# hugh0620
請傳檔上來看看

hugh0620

回復 4# GBKEE


    大大~ 執行的結果會卡在產生第21 Sheet 時~ 會有錯誤
   錯誤產生時~ 值行到第26行指令
   26.    .Name = Sheet2.Cells(2 + N, 1)    '標籤名稱
   如附件
    Data_VBA完成版_2.rar (102.04 KB)

下載次數: 26

2011-3-23 09:07

GBKEE

回復 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

複製代碼