iceandy6150

回復 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同，好像也沒規則可言，我每個類別點來點去，發現是不一樣的字號
往前幾個回文，我有貼圖片，裡面也可看到

感恩，謝謝

yen956

試試看:
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

yen956

抱歉, 沒一直看到最後一頁就回覆,
就當沒回覆這一回事, 抱歉!!
補圖(頁碼部份):

GBKEE

回復 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
沒有關係的,論壇需要熱心的會員參與.

iceandy6150

感謝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
   
4. 
   
5. 
   
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)
    
15. 
    
16. '我要將所找到的儲存格右邊那格的值傳給K，可是語法不對，我也不會
    
17.            
    
18.             MsgBox (Rng)
    
19.             MsgBox (k)
    
20.             
    
21.             End With
    
22. End Sub

複製代碼

GBKEE

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

複製代碼

iceandy6150

回復 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項以上的語法，還是查不到
唉…超菜的我

iceandy6150

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)     有時候跑一次能執行，後來就警告了      
    
51. 
    
52.             Sh.[C2] = j      '@@@有時候是警告這一行錯誤
    
53.             Sh.Name = Rng
    
54.             
    
55.             j = ""              '這兩行是我覺得使用後清空，加這兩行錯誤也沒消失
    
56.             Rng = ""
    
57.             
    
58. 
    
59.             For Each xRow In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows '自動篩選範圍列的集合
    
60. 
    
61.                 If xRow.Row > 1 Then
    
62. 
    
63.                      R = Application.CountA(Sh.[D7:D19])                 '有輸入的資料數
    
64. 
    
65.                      With Sh.[D7].Offset(R)
    
66. 
    
67.                         .Cells(, 1) = xRow.Range("D1")
    
68. 
    
69.                         .Cells(, 5) = xRow.Range("F1")
    
70. 
    
71.                         .Cells(, 7) = xRow.Range("E1")
    
72. 
    
73. '@@@  大大，這邊可能還要再把日期加進E3，我不會寫 (其實看不太懂為什麼，所以不會改)
    
74.                      End With
    
75. 
    
76.                      If Application.CountA(Sh.[D7:D19]) = 13 Then
    
77. 
    
78.                          Sh.Copy , Sh
    
79. 
    
80.                          Set Sh = ActiveSheet
    
81. 
    
82.                         Sh.[D7:J19] = ""
    
83. 
    
84.                     End If
    
85. 
    
86.                 End If
    
87. 
    
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
     
103. 
     
104. End Sub

複製代碼

回復 26# GBKEE

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

[attach]17426[/attach]

[attach]17427[/attach]

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

[attach]17428[/attach]

iceandy6150

版大，不好意思，不知道為什麼會重覆傳，還有檔案、圖片都上不去，有空再傳一次，重覆的文再請版大刪掉，謝謝

c_c_lai

回復 30# iceandy6150
如果你目前使用的的網頁軟體無法上傳檔案的話，
請改用別的網頁軟體來上傳。
譬如你原本是使用 Firefox 上傳檔案，如果無法上傳，
則請試試改用 IE 來上傳檔案。