[發問] 將資料自動分類功能

iceandy6150

各位大大好
想請問一記帳功能，需求如下

工作表1：是輸入區     有---日期         項目  金額     人員    類別
                                      例：102/8/5    頭款   5000   小王    廠商
                                              102/8/7    貨款   2000   老李    公司
                                              102/8/9    出差   1000   小林    員工

工作表2：是歷史記錄，每天的工作表1的內容，要完整複製到工作表2存起來
                  而且不能蓋掉之前的紀錄。(可以的話，每天資料之間留兩列空白)

工作表3(含以後)，是各類別項目單

如：
工作表3(廠商類)，可放入10筆資料，如超過10筆，則需新開另一工作表(廠商類2)
                                 自動把工作表1中，類別為「廠商」的資料，複製到工作表3
                                 例：102/8/5    頭款   5000   小王    廠商

工作表4(公司類)。需求同工作表3。自動把工作表1中，類別為「公司」的資料，複製到工作表4

工作表5(員工類)。需求同工作表3。自動把工作表1中，類別為「員工」的資料，複製到工作表5

<工作表3~5只有每天使用，列印後就可以了，可清空舊資料>



因為目前工作表1,2都是手動輸入。工作表3~5，要每個資料從工作表1中，人工分類複製貼到各工作表去
如果有大大知道怎麼設定，或使用按鈕讓程式自己跑
將可節省很多時間
請各位指導，感謝!

iceandy6150

我想所需功能大概分兩部分
一是在工作表2由上而下找到空白可用處，再把工作表1的資料複製過來
二是去判斷類別，再將資料複製到各工作表

首先由上而下找到空白我寫不太出來
一直說有錯
Private Sub CommandButton1_Click()
Dim i As Integer
i = 1

Do
      If Worksheets("工作表2").Range(Cells(i, 1), Cells(i, 7)) = "" Then
      MsgBox (i)                 '顯示第i行是完全空白，表示可用
      Exit Do
      End If
i = i + 1
Loop

End Sub

我想做到逐列尋找(用i來做)
然後一個範圍內都是空白，語法不會寫，range()從第i列的第1欄到第7欄都空白就表示已經到底
若其中一欄非空白，就i=i+1繼續找下去

可是遇到瓶頸了
希望有大大能解答
謝謝

GBKEE

回復 2# iceandy6150

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim i As Integer, Sh As Worksheet
   
4.     Application.DisplayAlerts = False
   
5.     For Each Sh In Sheets
   
6.         If Sh.Name <> "工作表1" And Sh.Name <> "工作表2" Then Sh.Delete
   
7.         '活頁簿只留 工作表1：是輸入區,工作表2：是歷史記錄
   
8.     Next
   
9.     With Sheets("工作表2")
   
10.         If .UsedRange.Rows.Count = 1 Then               '沒有歷史紀錄
    
11.             Sheets("工作表1").UsedRange.Copy            '複製(含標頭)
    
12.             .Range("a1").PasteSpecial xlPasteValues
    
13.         Else
    
14.             Sheets("工作表1").UsedRange.Offset(1).Copy  '複製(不含標頭)
    
15.             .Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
    
16.             'Offset(3) :空2列->第3列貼上
    
17.         End If
    
18.         .UsedRange.Range("E:E").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
    
19.         '進階篩選 E欄 不重複資料到工作表最右欄 ***取得類別的分類***
    
20.         i = 2
    
21.         .Cells(1, .Columns.Count - 1) = .UsedRange.Range("E1")    '進階篩選的欄位名稱是E欄的標頭
    
22.         Do While .Cells(i, .Columns.Count) <> ""                  '工作表最右欄的儲存格 <>""
    
23.             Set Sh = Sheets.Add(, Sheets(Sheets.Count))           '新增的類別工作表
    
24.             Sh.Name = .Cells(i, .Columns.Count)
    
25.             .Cells(2, .Columns.Count - 1) = Sh.Name
    
26.            .UsedRange.AdvancedFilter xlFilterCopy, .Cells(1, .Columns.Count - 1).Resize(2), Sh.[a1], True
    
27.            '工作表2 進階篩選 準則[分類]="工作表1"最右欄的儲存格, 複製到新增的類別工作表[A1]
    
28.            Do While Sh.UsedRange.Rows.Count > 11                  '資料列>11列
    
29.                 Sh.Copy , Sheets(Sh.Index)                        '1 原工作表複製
    
30.                 Sh.Rows("11:" & Sh.Rows.Count).Delete             '2 原工作表刪除11列以下的資料(保持10列)
    
31.                 Set Sh = ActiveSheet                              '3 複製的工作表 指定給變數
    
32.                 Sh.Rows("2:11").Delete                            '4 複製的工作表刪除2:11列的資料
    
33.            Loop
    
34.            i = i + 1
    
35.         Loop
    
36.         .Cells(1, .Columns.Count).CurrentRegion = ""
    
37.     End With
    
38. End Sub

複製代碼

iceandy6150

回復 3# GBKEE


    感謝GBKEE大大的回覆，功能正常，除了一些小問題

1：Option Explicit 程式跟我說有問題，加上'當成註解後，運作正常

2：我的需求有點小出入
      (1)我其他的工作表(3~5)因為有畫好表格(單子)，所以不能刪除
           只能把工作表1的資料複製、貼進去
          (每張表格只能填10筆資料，所以超過10筆才要另開新表，原因在此)

           我想是不是把下列程式刪除?
           For Each Sh In Sheets
            If Sh.Name <> "工作表1" And Sh.Name <> "工作表2" Then Sh.Delete
            '活頁簿只留 工作表1：是輸入區,工作表2：是歷史記錄
            Next

             改成，把工作表3~5裡面的舊資料清空，例如A5~E14=""
  
        (2)在挑選類別的時候，例如有好幾筆
            第1筆， 如果是員工類，就放到"員工"工作表，A5~E5  (單子第1筆)
            第2筆， 如果是員工類，就放到"員工"工作表，A6~E6 (單子第2筆)
            第3筆， 如果是員工類，就放到"員工"工作表，A7~E7  (單子第3筆)
            第4筆， 如果是公司類，就放到"公司"工作表，A5~E5  (單子第1筆)
            第5筆， 如果是廠商類，就放到"廠商"工作表，A5~E5  (單子第1筆)
            第6筆， 如果是公司類，就放到"公司"工作表，A6~E6  (單子第2筆)
            第7筆， 如果是公司類，就放到"公司"工作表，A7~E7  (單子第3筆)
            以此類推，

            至於超過10筆就開新工作表部分，功能均正常，我再稍微修改即可

以上，感謝

iceandy6150

1. Private Sub CommandButton1_Click()
   
2. 'Option Explicit    (刪除)
   
3. 
   
4. 'Sub Ex()   (刪除)
   
5. 
   
6.     Dim i As Integer, Sh As Worksheet
   
7. 
   
8.     Application.DisplayAlerts = False
   
9. 
   
10.     For Each Sh In Sheets
    
11. 
    
12.         If Sh.Name <> "工作表1" And Sh.Name <> "工作表2" Then      'Sh.Delete   (把刪掉工作表的動作取消)
    
13. 
    
14.         '活頁簿只留 工作表1：是輸入區,工作表2：是歷史記錄
    
15.         
    
16.         Sh.Range("A2:E11").Value = ""     '(自己加上清除其餘工作表中，特定範圍清空資料的功能)
    
17.             
    
18.         End If
    
19. 
    
20.     Next
    
21. 
    
22.    
    
23.     With Sheets("工作表2")
    
24. 
    
25.         If .UsedRange.Rows.Count = 1 Then               '沒有歷史紀錄
    
26. 
    
27.             Sheets("工作表1").UsedRange.Copy            '複製(含標頭)
    
28. 
    
29.             .Range("a1").PasteSpecial xlPasteValues
    
30. 
    
31.         Else
    
32. 
    
33.             Sheets("工作表1").UsedRange.Offset(1).Copy  '複製(不含標頭)
    
34. 
    
35.             .Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
    
36. 
    
37.             'Offset(3) :空2列->第3列貼上
    
38. 
    
39.         End If
    
40. 
    
41.         .UsedRange.Range("E:E").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
    
42. 
    
43.         '進階篩選 E欄 不重複資料到工作表最右欄 ***取得類別的分類***
    
44. 
    
45.         i = 2
    
46. 
    
47.         .Cells(1, .Columns.Count - 1) = .UsedRange.Range("E1")    '進階篩選的欄位名稱是E欄的標頭
    
48. 
    
49.         Do While .Cells(i, .Columns.Count) <> ""                  '工作表最右欄的儲存格 <>""
    
50. 
    
51.             'Set Sh = Sheets.Add(, Sheets(Sheets.Count))           '新增的類別工作表     (這邊不新增工作表，故刪除)
    
52. 
    
53.             'Sh.Name = .Cells(i, .Columns.Count)                           ' (這邊不新增工作表，故刪除)
    
54. 
    
55.             '.Cells(2, .Columns.Count - 1) = Sh.Name                   ' (這邊不新增工作表，故刪除)
    
56. 
    
57. '這邊應該要加入，判斷為哪一類別，並把該列資料複製到那個類別的工作表去，但我不會寫，是下面這行?
    
58. 
    
59.            .UsedRange.AdvancedFilter xlFilterCopy, .Cells(1, .Columns.Count - 1).Resize(2), Sh.[a1], True    '左邊這行除錯說沒有WITH，但明明就有，好怪
    
60. 
    
61.            '工作表2 進階篩選 準則[分類]="工作表1"最右欄的儲存格, 複製到新增的類別工作表[A1]
    
62. 
    
63.            Do While Sh.UsedRange.Rows.Count > 11                  '資料列>11列
    
64. 
    
65.                 Sh.Copy , Sheets(Sh.Index)                        '1 原工作表複製
    
66. 
    
67.                 Sh.Rows("11:" & Sh.Rows.Count).Delete             '2 原工作表刪除11列以下的資料(保持10列)
    
68. 
    
69.                 Set Sh = ActiveSheet                              '3 複製的工作表 指定給變數
    
70. 
    
71.                 Sh.Rows("2:11").Delete                            '4 複製的工作表刪除2:11列的資料
    
72. 
    
73.            Loop
    
74. 
    
75.            i = i + 1
    
76. 
    
77.         Loop
    
78. 
    
79.         .Cells(1, .Columns.Count).CurrentRegion = ""
    
80. 
    
81.     End With
    
82. 
    
83. 'End Sub  (原本的，刪除)
    
84. End Sub

複製代碼

回復 4# iceandy6150

我修改了一下大大的程式
可是卡住不能運作了

iceandy6150

回復 5# iceandy6150


    已附加檔案
     工作表1如果按鈕不小心按到兩次
     會複製兩次到工作表2
     其餘工作表的表格我簡化過，跟正本差一些而已
      謝謝

iceandy6150

補充一下，實際上類別不止三種，可能高達十多種，我範例是舉三例
另外每一類別的工作表我可以手動建立
萬一後面又要再多新的類別，我也可以慢慢增加

要搜尋類別，我是想到兩種方式
1.是用CASE，把會用到的都先內建，再把各類編號
    IF 工作表1.類別.cells().value = "公司" then k=1
    IF 工作表1.類別.cells().value = "員工" then k=2
    以此類推
   然後CASE(K)做判斷  去做複製、貼過去的動作

2.設一變數A = 工作表1的第i筆資料的類別的值  (例如是公司)
   再逐一找工作表的名稱，看是否與A一樣，若一樣則去做複製、貼過去的動作
For Each Sh In Sheets
        If Sh.Name = A then  做複製、貼過去的動作
        end if
next

不曉得這樣行不行得通?
謝謝

GBKEE

回復 7# iceandy6150

試試看

iceandy6150

回復 8# GBKEE

GBKEE版大您好

試了一下您的檔案後，問題如下

一、    With Sheets("工作表2")
        If .UsedRange.Rows.Count = 1 Then              '沒有歷史紀錄
        這一行無論有沒有資料都無法執行，就直接跳ELSE那一塊了
        所以我改成
        If .Cells(1, 1).Value = "" Then       功能相同

二、篩選及建立類別工作等工作，所用到的資料應該是輸入區(工作表1)的資料
       所以我多加了end with
      再多加 With Sheets("工作表1")，讓篩選及建立類別工作等工作正常運作

三、    Else
            Sheets("工作表1").UsedRange.Offset(1).Copy  '複製(不含標頭)
            .Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
            'Offset(3) :空2列->第3列貼上
            
             這邊的 .Range("A" & .UsedRange.Rows.Count)老是會算錯
            嚴格來說是.UsedRange.Rows.Count會出錯
            我特地加兩行程式，顯示一下到底算出幾列來
            k = Sheets("工作表2").UsedRange.Rows.Count
           MsgBox (k)
           結果工作表2只有7列，程式跑出：已使用26列

           我不死心，於是在工作表2弄了一個按鈕
           一樣的程式跑看看已使用的列數，秀出來
           還是一樣已使用26，明明都是空白，我不知道為什麼
           但是拿來算工作表1就很正確

我上傳我修改後的檔案
目前狀態是，工作表1已經輸入一次資料，按了一次按鈕
所以產生了該產生的其他類別工作表
也把工作表1該複製的資料，都貼到工作表2了

工作表1裡面，是輸入好第2次的資料，但還沒按按鈕
(因為貼的動作會錯<.UsedRange.Rows.Count會出錯>)

再麻煩幫我看看問題出在哪裡
謝謝

GBKEE

回復 9# iceandy6150
請看看 Sheets("工作表2")最右邊的IV欄