123456
返回列表 上一主題 發帖

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

iceandy6150

帖子
129 
主題
25 
精華
0 
積分
159 
點名
0  
作業系統
win7 
軟體版本
office2010 
閱讀權限
20 
性別
男 
註冊時間
2011-12-24 
最後登錄
2022-12-12 
21# 跳轉到 »
發表於 2014-2-4 23:27 | 只看該作者
回復 20# GBKEE

A-附檔上總表G欄類別沒數字, 但工作表[保險231],[通訊203]..有數字 這些工作表的命名規則你沒說明!
     [總表]資料可在H欄加註辨別新舊資料
     16# 可能還要用一個工作表，裡面放參考值，比如說 類別為[一般事務費]，那sh.name就是[一般事務費279]，字號為[庶字第016號]
B-庶字第016號 在何處??
   
G大，關於問題A，因為原本是人工處理，<總表>中的G欄只會看到類別，不會有數字
比方說<總表>裡面[類別]打的是[保險]，人眼一看就知道要去找工作表<保險231>
然後把<保險231>裡面第一列D7，設定成    =總表!D48  (設定成在總表中的位置)
這樣就可以把<總表>的資料對應到<保險231>中
萬一有第2.3.4...筆資料，還得人工逐一設定成   =總表!D??

所以，可能也沒什麼命名規則，因為我也不知道為什麼保險要用231，通訊要用203，真的很抱歉
我只是好心幫忙，想說把人工處理的部分，利用程式做完而已

關於問題B，就在每個工作表的I3裡面，("零用金清單"這幾個字的右下方)
與問題A同，好像也沒規則可言，我每個類別點來點去，發現是不一樣的字號
往前幾個回文，我有貼圖片，裡面也可看到

感恩，謝謝
哈囉~大家好呀

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
22#
發表於 2014-2-5 00:08 | 只看該作者

試試看:
VBA code:
Option Explicit

Sub 清除資料()
    Dim i, msg As Integer, x, sh As Worksheet
    Set x = Sheets("輸入")
    Application.DisplayAlerts = False
   
    '若將工作頁命名為 "輸入","歷史","廠商類","員工類","公司類","廠商類(1)","廠商類(2)",...
    '則可依 Len(Sh.Name) 決定 Delete 或 Clearcontents
    For Each sh In Sheets
        If Len(sh.Name) > 3 Then
           sh.Delete
        ElseIf Len(sh.Name) = 3 Then
           sh.Range("A2:E11").ClearContents
        End If
    Next
   
    '清除篩選區的資料
    x.Range("G:K").Clear
   
    '是否清除輸入區的資料?
    msg = MsgBox("要清除輸入區的資料嗎?", vbYesNo)
    If msg = vbYes Then
       x.Range("A2:E" & x.UsedRange.Rows.Count).ClearContents
    End If
End Sub
   
Sub 存入歷史紀錄()
    Dim i, msg As Integer, sh, x, y As Worksheet
    Dim 舊日期, 新日期 As Date
    Set x = Sheets("輸入")
    Set y = Sheets("歷史")
    Application.ScreenUpdating = False
   
    '如果尚未有歷史紀錄(第一次), 從 "輸入" 複製到 "歷史" (含標頭)
    If y.UsedRange.Rows.Count = 1 Then
        x.Range("A1:E" & x.UsedRange.Rows.Count).Copy
        y.Range("A1").PasteSpecial xlPasteValues
    Else
        舊日期 = y.Range("A" & y.UsedRange.Rows.Count)
        新日期 = x.Range("A" & x.UsedRange.Rows.Count)
        
        '注意："輸入"頁 A欄(即日期欄), 應設定 資料驗証, 並設為 "日期",
        '否則 If 舊日期 < 新日期 Then 會判斷錯誤!!
        '從 "輸入"頁 複製到 "歷史"頁 (不含標頭, 且空2列)
        If 舊日期 < 新日期 Then
            x.Range("A2:E" & x.UsedRange.Rows.Count).Copy
            y.Range("A" & y.UsedRange.Rows.Count + 3).PasteSpecial xlPasteValues
        Else
            msg = MsgBox(DateValue(新日期) & " 已經存過了!!", vbOKOnly)
        End If
    End If
    Application.ScreenUpdating = True
End Sub

Sub 篩選資料()
   Dim i, UsedRow As Integer, x, sh, shOld As Worksheet
   Dim shName
   shName = Array("廠商類", "公司類", "員工類")
   Set x = Sheets("輸入")
   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   
   '因為 "廠商類"、"公司類"、"員工類" 只有每天使用，
   '列印後就可以清空舊資料, 故應依 "輸入" 篩選, 而不是依 "歷史"
   For i = 0 To 2
      Set sh = Sheets(shName(i))
      x.Activate
      
      '將進階篩選的 篩選準則 填入 x.[F3]
      x.[F3] = Left(shName(i), 2)
      
      '進階篩選 A:E欄 重複資料到 "G1"       ***測試用(多筆重複)***
      x.Range("A1:E" & x.UsedRange.Rows.Count).AdvancedFilter xlFilterCopy, x.Range("F2:F3"), x.Range("G1:K1"), False
            
      '進階篩選 A:E欄 不重複資料到 "G1"     ***實際用(不重複)***
      'x.Range("A1:E" & x.UsedRange.Rows.Count).AdvancedFilter xlFilterCopy, x.Range("F2:F3"), x.Range("G1:K1"), True
            
      '將 篩選結果 複製到對應的類別工作表
      x.Range("G:K").Copy
      sh.[A1].PasteSpecial xlPasteValues
         
      Do While sh.[A12] <> ""                    '直到對應的類別工作表[A12] = ""
         sh.Copy After:=Sheets(Sheets.Count)                 '1 複製原工作表
         sh.Rows("12:" & sh.Rows.Count).Delete               '2 將原工作表12列以下刪除(保留10列)
         Set shOld = sh                                      '3 將 shOld 設給原工作表
         Set sh = Sheets(Sheets.Count)                       '4 將 sh 設給新工作表
         sh.Rows("2:11").Delete                              '5 刪除新工作表 2:11 列
         shOld.[A1:E11].Copy                                 '6 複製原工作表的 格式 到新工作表
         sh.[A1].PasteSpecial xlPasteFormats
      Loop
   Next
   Application.ScreenUpdating = True
End Sub

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
23#
發表於 2014-2-5 00:34 | 只看該作者
抱歉, 沒一直看到最後一頁就回覆,
就當沒回覆這一回事, 抱歉!!
補圖(頁碼部份):

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
24#
發表於 2014-2-5 10:13 | 只看該作者
回復 21# iceandy6150
沒有規律性那你就用手動
  1. Option Explicit   '必須置於模組頂端 強制宣告變數
  2. Sub Ex()
  3.     Dim i As Integer, Sh As Worksheet, Rng As Range, xRow As Range, R As Integer
  4.     With Sheets("總表")
  5.         If .UsedRange.Rows.Count = 1 Then              '沒有歷史紀錄
  6.            Sheets("Sheet1").UsedRange.Copy            '複製(含標頭)
  7.             .Range("A1").PasteSpecial xlPasteValues
  8.         Else
  9.             Sheets("Sheet1").UsedRange.Offset(1).Copy  '複製(不含標頭)
  10.             .Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
  11.             'Offset(3) :空2列->第3列貼上
  12.         End If
  13.     End With
  14.     With Sheets("SHEET1")  '工作表:輸入區
  15.         .Range("A1").CurrentRegion.Range("G:G").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
  16.         i = 2
  17.         Do While .Cells(i, .Columns.Count) <> ""
  18.             .Range("A1").AutoFilter 7, .Cells(i, .Columns.Count)         '自動篩選
  19.             Set Sh = Sheets(類別表(.Cells(i, .Columns.Count)))           '指定到類別的工作表
  20.             For Each xRow In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows '自動篩選範圍列的集合
  21.                 If xRow.Row > 1 Then
  22.                      R = Application.CountA(Sh.[D7:D19])                 '有輸入的資料數
  23.                      With Sh.[D7].Offset(R)
  24.                         .Cells(, 1) = xRow.Range("D1")
  25.                         .Cells(, 5) = xRow.Range("F1")
  26.                         .Cells(, 7) = xRow.Range("E1")
  27.                      End With
  28.                      If Application.CountA(Sh.[D7:D19]) = 13 Then
  29.                          Sh.Copy , Sh
  30.                          Set Sh = ActiveSheet
  31.                         Sh.[D7:J19] = ""
  32.                     End If
  33.                 End If
  34.             Next
  35.         i = i + 1
  36.         Loop
  37.         .AutoFilterMode = False       '自動篩選模式:取消
  38.         .UsedRange.Offset(1).Clear    '資料輸入後清除掉
  39.        ' .Cells(1, .Columns.Count).EntireColumn = ""
  40.     End With
  41. End Sub
  42. Function 類別表(類別 As String)    '自訂函數: 尋找類別的工作表
  43.     Dim 表 As String, Sh As Worksheet
  44.     For Each Sh In Sheets                  'Sheets: 工作表的集合
  45.         If InStr(Sh.Name, 類別) = 1 And Application.CountA(Sh.[D7:D19]) = 13 Then  '類別的工作表[D7:D19]有輸入的資料數
  46.             表 = Sh.Name
  47.         ElseIf InStr(Sh.Name, 類別) = 1 And Application.CountA(Sh.[D7:D19]) < 13 Then
  48.             類別表 = Sh.Name
  49.             Exit For
  50.         End If
  51.     Next
  52.     If 類別表 = "" And 表 <> "" Then
  53.         Sheets(表).Copy , Sheets(表)
  54.         類別表 = ActiveSheet.Name
  55.     ElseIf 類別表 = "" And 表 = "" Then
  56.         '*** 找不到類別的工作表 複製 "表格" 的範本
  57.         Sheets("表格").Copy Sheets(1)
  58.         ActiveSheet.Name = 類別
  59.         類別表 = 類別
  60.     End If
  61. End Function
複製代碼
回復 23# yen956
沒有關係的,論壇需要熱心的會員參與.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

iceandy6150

帖子
129 
主題
25 
精華
0 
積分
159 
點名
0  
作業系統
win7 
軟體版本
office2010 
閱讀權限
20 
性別
男 
註冊時間
2011-12-24 
最後登錄
2022-12-12 
25#
發表於 2014-2-5 17:34 | 只看該作者
感謝G大及Y大的回復

我想再問一兩個小問題

1.每次寫程式，我都知道我想要做到什麼功能，但是程式都寫不出來，或錯
   要買什麼書來看才能增進我的程式能力呢?
   錄製巨集只能錄到操作過程，但是人為判斷及選擇，巨集錄不到

2.我現在設了一個參照表
            A           B
   1    物品    物品271
   2    保險    保險236
   3    一般    一般218

也將G大教的部分功能修改，我想讓程式從SHEET1(輸入區)去找類別
然後會去<參照表>尋找，例如找到(保險)(A,2)，那就將(B,2)的值傳給K
但是不知道如何做到，再麻煩各位熱心版友
謝謝
  1. Private Sub CommandButton4_Click()
  2.             
  3. Dim i As Integer, j, k As String


  6.     With Sheets("Sheet1")
  7.    
  8.     .UsedRange.Range("G:G").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
  9.     End With
  10.    
  11. i = 2
  12.             With Sheets("參照表")
  13.             Set Rng = .Range("A:A").Find(what:=Sheets("Sheet1").Cells(i, .Columns.Count))
  14.            k =.Range("A:A").Find(what:=Sheets("Sheet1").Cells(i, .Columns.Count).Next.Value)

  16. '我要將所找到的儲存格右邊那格的值傳給K，可是語法不對，我也不會
  17.            
  18.             MsgBox (Rng)
  19.             MsgBox (k)
  20.             
  21.             End With
  22. End Sub
複製代碼
哈囉~大家好呀

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
26#
發表於 2014-2-5 17:52 | 只看該作者
回復 25# iceandy6150
多錄製巨集:可知如何使用VBA的方法.函數.屬性時機,要功力的增進,不二方法下苦工(多看,多問,多練習).大多數書籍的內容,VBA說明都可找到.
  1. Option Explicit
  2. Private Sub CommandButton4_Click()
  3.     Dim i As Integer, j, k As String, Rng As Range
  4.     With Sheets("Sheet1")
  5.         .UsedRange.Range("G:G").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
  6.     End With
  7.     i = 2
  8.     With Sheets("參照表")
  9.         Set Rng = .Range("A:A").Find(what:=Sheets("Sheet1").Cells(i, .Columns.Count))
  10.         k = Rng.Offset(, 1)
  11.         MsgBox (Rng)
  12.         MsgBox (k)
  13.     End With
  14. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

iceandy6150

帖子
129 
主題
25 
精華
0 
積分
159 
點名
0  
作業系統
win7 
軟體版本
office2010 
閱讀權限
20 
性別
男 
註冊時間
2011-12-24 
最後登錄
2022-12-12 
27#
發表於 2014-2-5 20:46 | 只看該作者
回復 26# GBKEE


    天啊，就這麼一行
 k = Rng.Offset(, 1)
G大，很感謝你
我下午試了一個多小時，就試不出來
activecell.next.value不行
selection.next.value不行
先selection.select再activecell.next.value也不行
selection.address可以秀出Rng找到哪一個
但是傳回來的是$A$5的東西
我想要右移一格$B$5的值卻不會寫
有address要去找該位置的值，我也不會
我都快瘋了我

G大，像我這種問題，靠錄製巨集能有解答？
我買了一本VBA的書，有300項以上的語法，還是查不到
唉…超菜的我
哈囉~大家好呀

TOP

iceandy6150

帖子
129 
主題
25 
精華
0 
積分
159 
點名
0  
作業系統
win7 
軟體版本
office2010 
閱讀權限
20 
性別
男 
註冊時間
2011-12-24 
最後登錄
2022-12-12 
28#
發表於 2014-2-6 00:39 | 只看該作者
  1. Private Sub CommandButton3_Click()
  2.     Dim Sh As Worksheet, i As Integer, ii As Integer, R As Integer, Ar 'Dim 宣告變數
  3.     Dim k As Integer
  4.     Dim j As String
  5.     Dim A As Range, Rng As Range, xRow As Range
  6.    
  7.     Application.DisplayAlerts = False
  8.     Application.ScreenUpdating = False
  9.     For Each Sh In Sheets
  10.    
  11.         If Sh.Name <> "Sheet1" And Sh.Name <> "總表" And Sh.Name <> "表格範本" And Sh.Name <> "黏存單(零)" And Sh.Name <> "參照表" Then Sh.Delete
  12.         '活頁簿只留 工作表1：是輸入區,工作表2：是歷史記錄 ,"表格範本"，黏存單(零),參照表
  13.     Next
  14.    
  15.     With Sheets("總表")
  16.         If .UsedRange.Rows.Count = 1 Then              '沒有歷史紀錄
  17.            Sheets("Sheet1").UsedRange.Copy            '複製(含標頭)
  18.             .Range("A1").PasteSpecial xlPasteValues
  19.             
  20.         Else
  21.             Sheets("Sheet1").UsedRange.Offset(1).Copy  '複製(不含標頭)
  22.             Sheets("總表").Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
  23.             'Offset(3) :空2列->第3列貼上
  24.            
  25.         End If
  26.         
  27.     End With
  28.    
  29.    
  30.     With Sheets("Sheet1")
  31.    
  32.     .UsedRange.Range("G:G").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
  33.     '進階篩選 E欄 不重複資料到工作表最右欄 ***取得類別的分類***
  34.     'AdvancedFilter:進階篩選
  35.     'xlFilterCopy:進階篩選的資料顯示在其他地方
  36.     '.Cells(1, .Columns.Count) ->工作表的最右欄第1個儲存格->進階篩選的資料顯示的地方
  37.        i = 2
  38.         Do While .Cells(i, .Columns.Count) <> ""                  '工作表最右欄的儲存格 <>""
  39.             .Range("A:G").AutoFilter 7, .Cells(i, .Columns.Count)          'AutoFilter: 自動篩選 ,第7欄(類別)的準則為 .Cells(i, .Columns.Count)
  40.             Sheets("表格範本").Copy , Sheets(Sheets.Count)
  41.             Set Sh = ActiveSheet
  42.             
  43.             
  44.             With Sheets("參照表")
  45.             Set Rng = .Range("A:A").Find(what:=Sheets("Sheet1").Cells(i, .Columns.Count))
  46.             'MsgBox (Rng)
  47.             j = Rng.Offset(, 1)
  48.             End With
  49.             
  50. '@@@上面那行  j = Rng.Offset(, 1)     有時候跑一次能執行，後來就警告了      

  52.             Sh.[C2] = j      '@@@有時候是警告這一行錯誤
  53.             Sh.Name = Rng
  54.             
  55.             j = ""              '這兩行是我覺得使用後清空，加這兩行錯誤也沒消失
  56.             Rng = ""
  57.             

  59.             For Each xRow In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows '自動篩選範圍列的集合

  61.                 If xRow.Row > 1 Then

  63.                      R = Application.CountA(Sh.[D7:D19])                 '有輸入的資料數

  65.                      With Sh.[D7].Offset(R)

  67.                         .Cells(, 1) = xRow.Range("D1")

  69.                         .Cells(, 5) = xRow.Range("F1")

  71.                         .Cells(, 7) = xRow.Range("E1")

  73. '@@@  大大，這邊可能還要再把日期加進E3，我不會寫 (其實看不太懂為什麼，所以不會改)
  74.                      End With

  76.                      If Application.CountA(Sh.[D7:D19]) = 13 Then

  78.                          Sh.Copy , Sh

  80.                          Set Sh = ActiveSheet

  82.                         Sh.[D7:J19] = ""

  84.                     End If

  86.                 End If

  88.             Next
  89.             i = i + 1
  90.        Loop
  91.         
  92.         k = 1
  93.         Do While .Cells(k, .Columns.Count) <> ""
  94.         .Cells(k, .Columns.Count) = ""
  95.         k = k + 1
  96.         Loop
  97.         
  98.         '.Cells(1, .Columns.Count).CurrentRegion = ""
  99.         .AutoFilterMode = False
  100.     End With
  101.     Application.ScreenUpdating = True
  102.     Me.Activate

  104. End Sub
複製代碼
回復 26# GBKEE

大大，我把您第一次的程式修改一下，可是有些地方警告說沒有WITH和區域變數
快完成了，幫我看看，謝謝

[attach]17426[/attach]

[attach]17427[/attach]

庶字第XX號，的XX由人工手動輸入即可

[attach]17428[/attach]
哈囉~大家好呀

TOP

iceandy6150

帖子
129 
主題
25 
精華
0 
積分
159 
點名
0  
作業系統
win7 
軟體版本
office2010 
閱讀權限
20 
性別
男 
註冊時間
2011-12-24 
最後登錄
2022-12-12 
29#
發表於 2014-2-6 01:10 | 只看該作者
版大，不好意思，不知道為什麼會重覆傳，還有檔案、圖片都上不去，有空再傳一次，重覆的文再請版大刪掉，謝謝
哈囉~大家好呀

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
30#
發表於 2014-2-6 06:16 | 只看該作者
回復 30# iceandy6150
如果你目前使用的的網頁軟體無法上傳檔案的話，
請改用別的網頁軟體來上傳。
譬如你原本是使用 Firefox 上傳檔案，如果無法上傳，
則請試試改用 IE 來上傳檔案。

TOP

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
123456
返回列表 上一主題