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

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

2^#

發表於 2014-1-29 23:35 | 只看該作者

我想所需功能大概分兩部分
一是在工作表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

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2014-1-30 14:09 | 只看該作者

回復 2# iceandy6150

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

4^#

發表於 2014-1-31 11:10 | 只看該作者

回復 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筆就開新工作表部分，功能均正常，我再稍微修改即可

以上，感謝

哈囉~大家好呀

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

5^#

發表於 2014-1-31 14:00 | 只看該作者

Private Sub CommandButton1_Click()
'Option Explicit (刪除)
'Sub Ex() (刪除)
Dim i As Integer, Sh As Worksheet
Application.DisplayAlerts = False
For Each Sh In Sheets
If Sh.Name <> "工作表1" And Sh.Name <> "工作表2" Then 'Sh.Delete (把刪掉工作表的動作取消)
'活頁簿只留工作表1：是輸入區,工作表2：是歷史記錄
Sh.Range("A2:E11").Value = "" '(自己加上清除其餘工作表中，特定範圍清空資料的功能)
End If
Next
With Sheets("工作表2")
If .UsedRange.Rows.Count = 1 Then '沒有歷史紀錄
Sheets("工作表1").UsedRange.Copy '複製(含標頭)
.Range("a1").PasteSpecial xlPasteValues
Else
Sheets("工作表1").UsedRange.Offset(1).Copy '複製(不含標頭)
.Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
'Offset(3) :空2列->第3列貼上
End If
.UsedRange.Range("E:E").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
'進階篩選 E欄不重複資料到工作表最右欄 ***取得類別的分類***
i = 2
.Cells(1, .Columns.Count - 1) = .UsedRange.Range("E1") '進階篩選的欄位名稱是E欄的標頭
Do While .Cells(i, .Columns.Count) <> "" '工作表最右欄的儲存格 <>""
'Set Sh = Sheets.Add(, Sheets(Sheets.Count)) '新增的類別工作表 (這邊不新增工作表，故刪除)
'Sh.Name = .Cells(i, .Columns.Count) ' (這邊不新增工作表，故刪除)
'.Cells(2, .Columns.Count - 1) = Sh.Name ' (這邊不新增工作表，故刪除)
'這邊應該要加入，判斷為哪一類別，並把該列資料複製到那個類別的工作表去，但我不會寫，是下面這行?
.UsedRange.AdvancedFilter xlFilterCopy, .Cells(1, .Columns.Count - 1).Resize(2), Sh.[a1], True '左邊這行除錯說沒有WITH，但明明就有，好怪
'工作表2 進階篩選準則[分類]="工作表1"最右欄的儲存格, 複製到新增的類別工作表[A1]
Do While Sh.UsedRange.Rows.Count > 11 '資料列>11列
Sh.Copy , Sheets(Sh.Index) '1 原工作表複製
Sh.Rows("11:" & Sh.Rows.Count).Delete '2 原工作表刪除11列以下的資料(保持10列)
Set Sh = ActiveSheet '3 複製的工作表指定給變數
Sh.Rows("2:11").Delete '4 複製的工作表刪除2:11列的資料
Loop
i = i + 1
Loop
.Cells(1, .Columns.Count).CurrentRegion = ""
End With
'End Sub (原本的，刪除)
End Sub

複製代碼

回復 4# iceandy6150

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

哈囉~大家好呀

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

6^#

發表於 2014-1-31 18:20 | 只看該作者

回復 5# iceandy6150

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

Book1.rar (24.45 KB)

測試檔

哈囉~大家好呀

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

7^#

發表於 2014-1-31 18:57 | 只看該作者

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

要搜尋類別，我是想到兩種方式
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

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

8^#

發表於 2014-2-1 07:22 | 只看該作者

本帖最後由 GBKEE 於 2014-2-1 10:00 編輯

回復 7# iceandy6150

試試看

Ex.rar (14.91 KB)

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 129
主題: 25
精華: 0
積分: 159
點名: 0
作業系統: win7
軟體版本: office2010
閱讀權限: 20
性別: 男
註冊時間: 2011-12-24
最後登錄: 2022-12-12

9^#

發表於 2014-2-2 23:54 | 只看該作者

回復 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會出錯>)

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

ttt.rar (18.02 KB)

哈囉~大家好呀

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

10^#

發表於 2014-2-3 07:19 | 只看該作者

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

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.