要搜尋類別，我是想到兩種方式
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
Private Sub CommandButton1_Click()
Dim myRgn As Range
Dim a As Integer
Set myRgn = Range("D7:J19")
ThisWorkbook.Names.Add "DataRange", myRgn
'(以上是網路看來的)
With Sheets("工作表1")
With Range("DataRange")
a = .UsedRange.Rows.Count
End With
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
'注意："輸入"頁 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
我原本的程式裡面加了防呆功能，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
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
