iceandy6150

回復 34# c_c_lai

C大您好，不知道為什麼，第3頁以後的文章，包括您的文章，都無法顯示了
我只能從[提醒]裡面去按回覆您的文章

昨晚我用IE開兩三個視窗無效，用CHROME開兩三個也無效
自己回覆的帖也看不到，只能看到第30則文章而已

[attach]17434[/attach]

c_c_lai

回復 31# iceandy6150
你可以請教  小誌版大。

GBKEE

回復 28# iceandy6150
錄製巨集能有解答？? 還要多看VBA說明.練習,了解它的範例(書本上的函數,方法,屬性,VBA說明都有)

下載 (47.15 KB)

2014-2-6 07:56

1. With Sheets("參照表")
   
2.             Set Rng = .Range("A:A").Find(what:=Sheets("Sheet1").Cells(i, .Columns.Count))
   
3.             MsgBox Rng Is Nothing '是 True 沒有找到 下面就錯誤
   
4.             '沒有物件指定到 Rng
   
5.             j = Rng.Offset(, 1)
   
6.             End With
   
7.             Sh.[C2] = j      'Rng Is Nothing 也會有錯誤
   
8.             Sh.Name = Rng    'Rng Is Nothing 也會有錯誤
   
9.             
   
10.             j = ""              '沒用的:這兩行是我覺得使用後清空，加這兩行錯誤也沒消失
    
11.             Rng = ""
    
12.             For Each xRow In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows '自動篩選範圍列的集合
    
13.                 If xRow.Row > 1 Then
    
14.                      R = Application.CountA(Sh.[D7:D19])                 '有輸入的資料數
    
15.                      With Sh
    
16.                         .[E3] = xRow.Range("B1")                        '@@@  再把日期加進E3
    
17.                         .[D7].Offset(R).Cells(, 1) = xRow.Range("D1")
    
18.                         .[D7].Offset(R).Cells(, 5) = xRow.Range("F1")
    
19.                         .[D7].Offset(R).Cells(, 7) = xRow.Range("E1")
    
20.                      End With

複製代碼

iceandy6150

回復 33# GBKEE

我終於完成囉，附上檔案

零用金清單-上傳用.rar (47.84 KB)

下載次數: 16

2014-2-6 21:43

感謝G大及其他熱心版友的幫忙

c_c_lai

回復 34# iceandy6150
請將以下之七項 "X: X" 內之空白去除；

1. 1.  .UsedRange.Range("G: G").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
   
2. 2.  .Range("A: G").AutoFilter 7, .Cells(i, .Columns.Count)  '  AutoFilter:  自動篩選 ,第7欄(類別)的準則為 .Cells(i, .Columns.Count)
   
3. 3.  Set Rng = .Range("A1: A18").Find(What:=M)
   
4. 4.  R = Application.CountA(Sh.[D7: D19])   '  有輸入的資料數
   
5. 5.  If Application.CountA(Sh.[D7: D19]) = 13 Then
   
6. 6.  Sh.[D7: J19] = ""
   
7. 7.  Sh.[D33: J45] = ""

複製代碼

否則會產生錯誤訊息。 (正確應為 "X:X")

1. 1.  .UsedRange.Range("G:G").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
   
2. 2.  .Range("A:G").AutoFilter 7, .Cells(i, .Columns.Count)  '  AutoFilter:  自動篩選 ,第7欄(類別)的準則為 .Cells(i, .Columns.Count)
   
3. 3.  Set Rng = .Range("A1:A18").Find(What:=M)
   
4. 4.  R = Application.CountA(Sh.[D7:D19])   '  有輸入的資料數
   
5. 5.  If Application.CountA(Sh.[D7:D19]) = 13 Then
   
6. 6.  Sh.[D7:J19] = ""
   
7. 7.  Sh.[D33:J45] = ""

複製代碼

c_c_lai

回復 34# iceandy6150
又、以下處裡清除動作：

1.         '  k = 1
   
2.         '  Do While .Cells(k, .Columns.Count) <> ""
   
3.         '      .Cells(k, .Columns.Count) = ""
   
4.         '      k = k + 1
   
5.         '  Loop

複製代碼

可參考 GBKEE 在 "對特定欄進行篩選和替代資料" 一文中提及的簡潔、扼要之使用語法，
而替換 Do While ~ Loop 循環判斷直至條件不成立為止的用法
(P.S.  雖然此處只有兩欄資料，但總共卻執行了三趟)。

1. .Cells(1, .Columns.Count).CurrentRegion = ""

複製代碼

GBKEE

回復 34# iceandy6150
萬丈高樓,從地起,你已在打地基了
依你的 [零用金清單-上傳用.rar] 修改一下

1. Option Explicit   '必須置於模組頂端 強制宣告變數
   
2. Private Sub CommandButton1_Click()
   
3.     Dim Sh As Worksheet, i As Integer, R As Integer, Rng As Range, xRow As Range
   
4.     Application.ScreenUpdating = False
   
5.     With Sheets("總表")
   
6.         If .UsedRange.Rows.Count = 1 Then              '沒有歷史紀錄
   
7.            Sheets("Sheet1").UsedRange.Copy             '複製(含標頭)
   
8.             .Range("A1").PasteSpecial xlPasteValues
   
9.         Else
   
10.             Sheets("Sheet1").UsedRange.Offset(1).Copy  '複製(不含標頭)
    
11.             .Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
    
12.                                                        'Offset(3) :空2列->第3列貼上
    
13.         End If
    
14.     End With
    
15.     With Sheets("Sheet1")
    
16.         .UsedRange.Range("G:G").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
    
17.         i = 2
    
18.         Do While .Cells(i, .Columns.Count) <> ""                          '工作表最右欄的儲存格 <>""
    
19.             .Range("A:G").AutoFilter 7, .Cells(i, .Columns.Count)          'AutoFilter: 自動篩選 ,第7欄(類別)的準則為 .Cells(i, .Columns.Count)
    
20.             Set Rng = Sheets("參照表").Range("A1:A18").Find(.Cells(i, .Columns.Count)).Offset(, 1)
    
21.             Set Sh = Sheets(類別表(Rng))
    
22.             Sh.Activate
    
23.             For Each xRow In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows '自動篩選範圍列的集合
    
24.                 If xRow.Row > 1 Then
    
25.                     R = Application.CountA(Sh.[D7:D19])                 '有輸入的資料數
    
26.                     With Sh
    
27.                         .[E3,E29] = xRow.Range("B1")                    '日期加進E3,E29
    
28.                         
    
29.                         .[D7].Offset(R).Cells(, 1) = xRow.Range("D1")
    
30.                         .[D7].Offset(R).Cells(, 5) = xRow.Range("F1")
    
31.                         .[D7].Offset(R).Cells(, 7) = xRow.Range("E1")
    
32.                         
    
33.                         .[D33].Offset(R).Cells(, 1) = xRow.Range("D1")
    
34.                         .[D33].Offset(R).Cells(, 5) = xRow.Range("F1")
    
35.                         .[D33].Offset(R).Cells(, 7) = xRow.Range("E1")
    
36.                     End With
    
37.                     If Application.CountA(Sh.[D7:D19]) = 13 Then
    
38.                         Sh.Copy , Sh
    
39.                         Set Sh = ActiveSheet
    
40.                         Sh.[D7:J19,D33:J45] = ""
    
41.                         'Sh.[D33:J45] = ""
    
42.                     End If
    
43.                 End If
    
44.             Next
    
45.             i = i + 1
    
46.         Loop
    
47.         .AutoFilterMode = False   '**** 取消自動篩選模式,資料全部顯示下面的清除才有效果*****
    
48.    '     .UsedRange.Offset(1) = "'"                      'UsedRange: 工作表的已使用範圍
    
49.         '.Cells(1, .Columns.Count).EntireColumn = ""    'EntireColumn:整欄
    
50.         '.Cells(1, .Columns.Count).CurrentRegion = ""   'CurrentRegion: 有資料的延伸範圍
    
51.      '   .Activate
    
52.     End With
    
53.     Application.ScreenUpdating = True
    
54. End Sub
    
55. Function 類別表(類別 As Range) As String      '自訂函數: 尋找類別的工作表
    
56.     Dim 表 As String, Sh As Worksheet
    
57.     For Each Sh In Sheets                  'Sheets: 工作表的集合
    
58.         If InStr(Sh.Name, 類別) = 1 And Application.CountA(Sh.[D7:D19]) = 13 Then  '類別的工作表[D7:D19]有輸入的資料數
    
59.             表 = Sh.Name
    
60.         ElseIf InStr(Sh.Name, 類別) = 1 And Application.CountA(Sh.[D7:D19]) < 13 Then
    
61.             類別表 = Sh.Name
    
62.             Exit For
    
63.         End If
    
64.     Next
    
65.     If 類別表 = "" And 表 <> "" Then
    
66.         Sheets(表).Copy , Sheets(表)
    
67.         ActiveSheet.[C2] = 類別.Offset(, 2)
    
68.         類別表 = ActiveSheet.Name
    
69.     ElseIf 類別表 = "" And 表 = "" Then
    
70.         '*** 找不到類別的工作表 複製 "表格" 的範本
    
71.         Sheets("表格範本").Copy Sheets(1)
    
72.         ActiveSheet.Name = 類別
    
73.         ActiveSheet.[C2] = 類別.Offset(, 1)
    
74.         類別表 = 類別
    
75.     End If
    
76. End Function

複製代碼

Hsieh

回復 34# iceandy6150
湊個熱鬧

1. Sub CreateTable()
   
2. Dim i%, Ar(), Rng As Range, A As Range, sht As Object, ky As Variant, k&, s&
   
3. Set sht = CreateObject("Scripting.Dictionary")
   
4. Application.DisplayAlerts = False
   
5. With Sheets("Sheet1")
   
6. i = .Index + 1
   
7. Do Until Sheets.Count < i '刪除Sheet1之後的工作表
   
8.    Sheets(i).Delete
   
9.    i = .Index + 1
   
10. Loop
    
11. For Each A In .Range(.[G2], .[G2].End(xlDown)) '分類儲存
    
12.   Set Rng = Sheets("參照表").[A:A].Find(A, lookat:=xlWhole) '找到參照
    
13.   If IsEmpty(sht(Rng.Offset(, 1).Value)) Then '分類第一個
    
14.   ReDim Preserve Ar(0)
    
15.      Ar(0) = Array(A.Offset(, -3).Value, "", "", "", A.Offset(, -1).Value, "", A.Offset(, -2).Value)
    
16.      sht(Rng.Offset(, 1).Value) = Ar
    
17.      Else '分類繼續找到
    
18.      Ar = sht(Rng.Offset(, 1).Value)
    
19.      s = UBound(Ar)
    
20.      ReDim Preserve Ar(s + 1)
    
21.      Ar(s + 1) = Array(A.Offset(, -3).Value, "", "", "", A.Offset(, -1).Value, "", A.Offset(, -2).Value)
    
22.      sht(Rng.Offset(, 1).Value) = Ar
    
23.      Erase Ar
    
24.    End If
    
25. Next
    
26. For Each ky In sht.keys '用分類當成索引值
    
27. Ar = sht(ky)
    
28. s = UBound(Ar) + 1
    
29. With Sheets.Add(after:=Sheets(Sheets.Count)) '新增工作表
    
30. .Name = ky '以分類為表名稱
    
31.   Set Rng = Sheets("表格範本").[A1:K22] '表格範本範圍
    
32.   Rng.Copy .[A1]: k = 0: .Cells(k + 2, 3) = ky
    
33.   For i = 0 To UBound(Ar) '寫入資料
    
34.      .Cells(i + 7 + Int(i / 13) * 13, 4).Resize(, 7) = Application.Index(Ar, i)
    
35.     If (i + 1) Mod 13 = 0 Then k = k + 26: Rng.Copy .[A1].Offset(k, 0): .Cells(k + 2, 3) = ky '13筆為一個表格
    
36.   Next
    
37. End With
    
38. Next
    
39. '轉至總表
    
40. If MsgBox("是否存入總表", vbYesNo) = 6 Then .Range("A1").CurrentRegion.Offset(1).Copy Sheets("總表").Cells(.Rows.Count, 1).End(xlUp).Offset(3)
    
41. MsgBox "分類完成"
    
42. End With
    
43. End Sub

複製代碼

iceandy6150

回復 38# Hsieh

感謝很多大大熱心回復，感動到快哭了
來不及消化之前，先發問一下

我原本的程式裡面加了防呆功能，Sheet1最右邊篩選出來的，如果參照表沒有該類別，會出錯
於是加了下列程式
            With Sheets("參照表")
            M = Sheets("Sheet1").Cells(i, .Columns.Count).Value
            Set Rng = .Range("A2:A30").Find(What:=M)
            
            If Rng Is Nothing Then
                MsgBox ("找不到<<" & M & ">>相對應類別，請增修參照表")
                MsgBox ("請記得去總表把本次資料刪除，以免重覆")
                Sheets("Sheet1").AutoFilterMode = False
                Application.ScreenUpdating = True
                Me.Activate
                Exit Sub
            End If

           Sh.[C2] = Rng.Offset(, 2)
            Sh.Name = Rng.Offset(, 1)
            End With

然後Sheet1的[類別]欄為了怕輸入參照表沒有的東西，所以設了下拉式選單
還有為了清除乾淨，讓第二次、第三次使用時，.usedrange.rows.count不會出錯
(明明下面列都沒東西了，還是抓很下面的列)
所以用程式去做輕除，設了按鈕2，如下

Private Sub CommandButton2_Click()
     Worksheets("參照表").Activate
     Worksheets("參照表").Range("A1:A30").Select
     Worksheets("參照表").Range("A30").Activate
     Selection.CreateNames Top:=True, Left:=False, Bottom:=False, Right:= _
     False
'其實A1:A30應該是A1到A欄有資料的最後那一列，但我不會設
'只好先預設30個類別，以上是錄製巨集再複製貼上的

     Worksheets("Sheet1").Activate
Sheets("Sheet1").Range("A2:G150").Delete (xlShiftUp)
'這兩行是清空資料，一樣是預設到150，絕對夠用
'如果要~有多少資料就刪除多少資料，我又不會了

With Sheets("Sheet1")
    With .Range("G2:G150").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:="=類別"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
End With
End Sub
'這邊是設定下拉式選單，一樣錄巨集再貼過來用

最後想設一個防呆，檢查Sheet1的G欄(類別)，是否有[空白]
如果沒輸入，就不能篩選分類，也沒辦法去<參照頁>對照
大概知道要設定範圍~~Sheet1.Range(G2到G欄最後一列)
如果此範圍有空白欄，警告，並Exit sub
但我試不出來，請教各位大大解答了   <按鈕4>

Private Sub CommandButton4_Click()
Dim i
'方法一，失敗
For Each c In Sheets("Sheet1").UsedRange("G:G")
If c = "" Then i = 1
Else i = 0
End If
Next
'方法二，失敗
'If IsEmpty(Sheets("Sheet1").UsedRange("G:G")) Then
'方法三，失敗
'If Sheets("Sheet1").UsedRange("G:G").SpecialCells(xlCellTypeBlanks) Is Nothing Then
'方法四，失敗
'i = Sheets("Sheet1").UsedRange("G:G").SpecialCells(xlCellTypeBlanks)
'MsgBox (i)

If i = 1 Then MsgBox ("有空格")
Else
MsgBox ("無空格")
End If
End Sub

其實好像應該先檢查Sheet1.usedrange.rows.count
(先知道輸入幾筆資料，假設23筆)
再去數G欄有幾筆，小於23筆就知道有某幾筆沒填類別
有時候1~18筆都有選類別，19.20.21沒選，22.23有選

以上發問，感謝

GBKEE

回復 39# iceandy6150

1. Option Explicit
   
2. Private Sub CommandButton2_Click()
   
3.     Sheets("參照表").UsedRange.Columns(1).CreateNames True
   
4.     With Sheets("Sheet1").Range("G2:G150").Validation
   
5.         .Add Type:=xlValidateList, Formula1:="=" & Sheets("參照表").UsedRange.Cells(1)
   
6.     End With
   
7. End Sub
   
8. Private Sub CommandButton4_Click()
   
9.     Dim i As Integer, C As Range
   
10.     For Each C In Sheets("Sheet1").UsedRange.Columns(7).Cells
    
11.         If C = "" Then MsgBox ("有空格"): Exit Sub
    
12.     Next
    
13.     MsgBox ("無空格")
    
14. End Sub
    
15. Sub Ex()
    
16.     Dim i As Integer
    
17.     'UsedRange.RANGE("G:G") -> 已使用範圍的G欄會延伸到工作表的的底部
    
18.     'UsedRange.Columns(7)   -> 僅已使用範圍第1欄範圍算起的第7欄範圍
    
19.     For i = 1 To 3
    
20.         With Sheets.Add(, Sheets(Sheets.Count))
    
21.             If i = 1 Then
    
22.                 .[F1,I5] = "AA"
    
23.             ElseIf i = 2 Then
    
24.                 .[D1,F5] = "AA"
    
25.             Else
    
26.                 .[D2,F5] = "AA"
    
27.             End If
    
28.             MsgBox .UsedRange.Address
    
29.             MsgBox .UsedRange.Columns(5).Address
    
30.             MsgBox .UsedRange.Range("E:E").Address        '.[D2,F5]->工作表第一列沒資料有錯誤
    
31.         End With
    
32.     Next
    
33. End Sub

複製代碼