- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
14#
發表於 2012-2-15 12:27
| 只看該作者
本帖最後由 GBKEE 於 2012-2-15 14:42 編輯
回復 13# owen9399
你附檔中 Sheet("交貨資料庫") VBA 的Codename 為 Sheet2
Sheet("進貨資料庫") VBA 的Codename 為 Sheet3
Sheet1 的事件程式碼 :輸入序號 或用下拉式選單 直接秀出公司名稱- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim xM
- If Intersect(Target, Range("A2:A11")) Is Nothing And Intersect(Target, Range("J2:J11")) Is Nothing _
- Or Target(1) = "" Or Target.Count > 1 Then Exit Sub
- xM = Application.Match(Target, [公司序號].Columns(1), 0)
- Target(1).Cells(1, 2) = [公司序號].Cells(xM, 2)
- End Sub
- Private Sub Worksheet_SelectionChange(ByVal Target As Range)
- On Error Resume Next
- [序號].Validation.Delete
- If Intersect(Target, Range("A2:A11")) Is Nothing And Intersect(Target, Range("J2:J11")) Is Nothing _
- Then Exit Sub
- Range("Q2", [Q2].End(xlDown)).Resize(, 2).Name = "公司序號"
- Target.Name = "序號"
- With [序號].Validation
- .Delete
- .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
- Operator:=xlBetween, Formula1:="=" & [公司序號].Columns(1).Address
- End With
- End Sub
- Sub 按鈕1_Click()
- Dim Rng As Range
- Set Rng = Sheet1.Range("A2:G11").SpecialCells(xlCellTypeVisible)
- With Sheet2.Range("A65536").End(xlUp).Offset(1)
- .Resize(Rng.Rows.Count, Rng.Columns.Count) = Rng.Value
- .CurrentRegion.Borders.LineStyle = 1 '畫線
- .CurrentRegion.Borders.ColorIndex = 1 '上色
- End With
- Rng.ClearContents
- End Sub
- Sub 按鈕2_Click()
- Dim Rng As Range
- Set Rng = Sheet1.Range("J2:N11").SpecialCells(xlCellTypeVisible)
- With Sheets("進貨資料庫").Range("A65536").End(xlUp).Offset(1)
- .Resize(Rng.Rows.Count, Rng.Columns.Count) = Rng.Value
- .CurrentRegion.Borders.LineStyle = 1
- .CurrentRegion.Borders.ColorIndex = 1
- End With
- Rng.ClearContents
- End Sub
- Sub 按鈕3_Click()
- Dim Rng As Range, S As String, xi As Integer
- Dim Sh As Worksheet
- Set Sh = Sheets("日報表") ' 日報表
- Sh.Cells.Clear
- With Sheets("交帳資料庫")
- If .AutoFilterMode Then .AutoFilterMode = False '取消篩選
- .Range("a1").AutoFilter '[自動篩選] 篩選出一個清單
- Set Rng = .AutoFilter.Range.Columns(6).Cells '[自動篩選]的第6欄
- For xi = 2 To Rng.Count '處裡: 第二欄 單元格
- If InStr(S, "," & Rng(xi) & ",") = False Then '檢查 儲存格 是否已出現過
- .Range("a1").AutoFilter Field:=6, Criteria1:=Rng(xi).Text '沒出現: 指定為篩選值
- S = S & "," & Rng(xi) & "," '加入已出現過的字串中
- .UsedRange.SpecialCells(xlCellTypeVisible).Copy Sh.Cells(Rows.Count, "b").End(xlUp).Offset(2) '複製: 資料表中篩選出的資料
- Sh.Cells(Rows.Count, "b").End(xlUp).Offset(2).CurrentRegion.Borders.LineStyle = 1
- Sh.Cells(Rows.Count, "b").End(xlUp).Offset(2).CurrentRegion.Borders.ColorIndex = 1
- End If
- Next
- .AutoFilterMode = False '取消篩選
- End With
- Sh.Activate
- End Sub
|
|
發表於 2012-2-8 11:19
| 
