Board logo

標題: 符合兩筆資料自行顯示地區 [打印本頁]
作者: 周大偉    時間: 2014-12-9 11:21     標題: 符合兩筆資料自行顯示地區

本帖最後由 周大偉 於 2014-12-9 11:26 編輯

前輩們, 早晨
小弟有一問題, 請各前輩協助, 問題是一個符合兩筆資料自行傳回地區, 現小弟把檔案上傳, 先行謝過前輩們,
祝願快樂, 謝!!
[attach]19732[/attach]
作者: owen06    時間: 2014-12-9 13:53

回復 1# 周大偉


    試試看
作者: GBKEE    時間: 2014-12-9 17:04

本帖最後由 GBKEE 於 2014-12-10 07:14 編輯

Function(自訂函數)
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     With Target
  4.         If (.Column = 3 Or .Column = 10) And .Row >= 4 Then
  5.             Cells(.Row, "q") = EX_地區(Cells(.Row, "C") & "," & Cells(.Row, "J")& ",")
  6.          End If
  7.     End With
  8. End Sub
  9. Private Function EX_地區(Msg As String) As String
  10.     Dim AR, A, i
  11.     EX_地區 = ""
  12.     AR = Sheets("工作表2").Range("A1").CurrentRegion
  13.     AR = Application.Transpose(Application.Transpose(AR))
  14.     For i = 1 To UBound(AR)
  15.         A = Application.WorksheetFunction.Index(AR, i)
  16.         If InStr(UCase(Join(A, ",")), UCase(Msg)) = 1 Then
  17.             EX_地區 = A(3)
  18.             Exit For
  19.         End If
  20.     Next
  21. End Function
複製代碼
作者: 周大偉    時間: 2014-12-9 19:50

謝謝樓上兩位大大,  想請教一個問題,
一般資料按自行顯示都會用上下列指令,
Private Sub Worksheet_Change(ByVal Target As Range)
可否會有其他開語法取代這句語法, 或有相同效果, 因小弟本身工作表已有程式, 而開頭第一句便是這句,
故程式便出現重複指令, 煩請大大們教導, 謝謝!!
作者: owen06    時間: 2014-12-9 22:47

回復 4# 周大偉


    既然你的程式是用 Private Sub Worksheet_Change(ByVal Target As Range)開頭，
    那直接將語法內容加入你的程式下面不行嗎？還是方便把程式內容貼上來看看嗎？
作者: GBKEE    時間: 2014-12-10 07:15

回復 4# 周大偉
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     '其他程式碼
  4.     '其他程式碼
  5.     Ex Target
  6.     '其他程式碼
  7.     '其他程式碼
  8. End Sub
  9. Private Sub Ex(T As Range)
  10.     Application.EnableEvents = False
  11.     With T
  12.         If (.Column = 3 Or .Column = 10) And .Row >= 4 Then
  13.             Cells(.Row, "q") = EX_地區(Cells(.Row, "C") & "," & Cells(.Row, "J") & ",")
  14.         End If
  15.     End With
  16.     Application.EnableEvents = True
  17. End Sub
  18. Private Function EX_地區(Msg As String) As String
  19.     Dim AR, A, i
  20.     EX_地區 = ""
  21.     AR = Sheets("工作表2").Range("A1").CurrentRegion
  22.     AR = Application.Transpose(Application.Transpose(AR))
  23.     For i = 1 To UBound(AR)
  24.         A = Application.WorksheetFunction.Index(AR, i)
  25.         If InStr(UCase(Join(A, ",")), UCase(Msg)) = 1 Then
  26.             EX_地區 = A(3)
  27.             Exit For
  28.         End If
  29.     Next
  30. End Function
複製代碼
作者: 周大偉    時間: 2014-12-10 18:45

本帖最後由 周大偉 於 2014-12-10 18:46 編輯

感謝兩位樓主回應, 先行謝過,
小弟真的沒法把現使用的程式與兩位大大所供的程式融合, 現把使用開的程式貼上, 請兩位樓主協助, 謝謝!!
Private Sub Worksheet_Change(ByVal T As Range)
Dim Rng As Range, A As Range, Dha As Workbook, pp
Application.EnableEvents = False
Set Dha = Workbooks("sss倉庫資料.xlsm")
Set Rng = Dha.Sheets(1).UsedRange
Select Case T.Column
Case 2
   If IsDate(T) Then T.Offset(, -1) = Month(T)
Case 3
   Set A = Rng.Columns(2).Find(T, lookat:=xlWhole)
   If A Is Nothing Then MsgBox "無此貨物編號": GoTo 10
   T.Offset(, 1) = A.Offset(, 1)
   T.Offset(, 2) = A.Offset(, 2)
   T.Offset(, 3) = A.Offset(, 3)
   T.Offset(, 5) = A.Offset(, 4)
Case 7
    Set A = Rng.Columns(2).Find(T.Offset(, -4), lookat:=xlWhole)
    pp = Application.SumIf(Range("C:G"), A, Range("G:G")) '計算倉庫提取總數
    If pp > (A.Offset(, 8) + A.Offset(, 10)) Then
        MsgBox T.Offset(, -3) & "存量不足重新填寫"
        T.Interior.ColorIndex = 26
        GoTo 10
    End If
    T.Interior.ColorIndex = xlNone
    pp = Application.SumIf(Range("C:G"), T.Offset(, -4), Range("G:G")) '計算倉庫提取總數
    A.Offset(, 8) = pp
    A.Offset(, 10) = A.Offset(, 7) + A.Offset(, 9) - A.Offset(, 8)
    T.Offset(, 2) = T * T.Offset(, 1)
    Dha.Save
End Select
10
Application.EnableEvents = True
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal T As Range, Cancel As Boolean)
    Dim A As Range
    If Not Application.Intersect(T, Range("A3:L" & Application.CountA([A3:A6]) + 2)) Is Nothing Then
        Cancel = True
        With Workbooks("sss倉庫資料.xlsm")
            Set A = .Sheets(1).UsedRange.Columns(2).Find(Range("C" & T.Row), lookat:=xlWhole)
            If A.Column <> 2 Or A = "" Then
                MsgBox "資料不正確 請查明"
                Range(Cells(T.Row, "A"), Cells(T.Row, "L")).Select
                Exit Sub
            End If
            If MsgBox(Range("C" & T.Row) & " " & Range("D" & T.Row) & Chr(10) _
                    & "取消 " & [G2] & " " & Range("G" & T.Row) & Chr(10) & "請注意 [本紀錄] 取消後無法復原", vbYesNo) = vbYes Then
                Application.ScreenUpdating = False
                Application.EnableEvents = False
                A.Offset(, 8) = Application.SumIf(Range("C:C"), A, Range("G:G")) - Range("G" & T.Row) '變更入貨總數於資料庫
                A.Offset(, 10) = A.Offset(, 7) + A.Offset(, 9) - A.Offset(, 8)
                .Save
                Range(Cells(T.Row, "A"), Cells(T.Row, "L")).Delete (3)
                Application.EnableEvents = True
                ActiveWorkbook.Save
                Application.ScreenUpdating = True
            End If
        End With
    End If
End Sub
作者: GBKEE    時間: 2014-12-11 06:42

回復 7# 周大偉
請將你原本的 Private Sub Worksheet_Change(ByVal T As Range)
複製在工作表的模組上,修改程序名稱為
例 Private Sub Ex_Sub1(ByVal T As Range)

原本的 Private Sub Worksheet_Change(ByVal T As Range)事件
修改內容如下
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Ex Target        'Target: 要傳遞給這副程式的變數
  4.    Ex_Sub1 Target
  5.     '其他程式碼
  6.    '其他程式碼
  7. End Sub
複製代碼
作者: 周大偉    時間: 2014-12-11 20:02

回復 8# GBKEE
謝謝樓主教導, 已成功, 感謝大大, 祝快樂,
謝謝!!



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)