程式碼修改

man65boy

請老師們幫小弟修改一下程式碼，2種的程式無法取得相融，附檔說明，謝謝!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, MM
With Target
     If .Columns.Count > 1 Then Exit Sub
     If .Column <> 6 Then Exit Sub '可變更讀取欄位
     If .Row < 2 Then Exit Sub
     If Target.Count > 3 Then Application.ScreenUpdating = False
     '超過三筆的，凍結執行過程，直到結束，加快執行速度
     For Each xR In Target
        With xR.Cells(1, 2)
             .FormulaR1C1 = "=VLOOKUP(RC[-1],產品編號!C[-6]:C[-2],2,0)"
             .Value = .Value
             .Replace "#N/A", "", Lookat:=xlWhole '清除找不到符合編號的錯誤值
             .Replace "0", "" '清除對應編號〔客戶名稱〕卻空白的０值
        End With
        Next
End With
With Target
If Target.Columns.Count > 1 Then Exit Sub
If Target.Column <> Range("M1").Column Then Exit Sub
For Each xR In Target
    If xR = "" Then GoTo NEXT_CELL
    MM = Application.Match(xR, Sheets("Sheet1").Range("A:A"), 0)
    If IsError(MM) Then GoTo NEXT_CELL
    xR = Sheets("Sheet1").Range("B" & MM).Value
NEXT_CELL:

Next
End With
End Sub





Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 13 And Target.Count = 1 Then UserForm3.Show 0
If Target.Column = 6 And Target.Count = 1 Then UserForm4.Show 0
End Sub

准提部林

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, MM
With Target
　　If .Columns.Count > 1 Then Exit Sub
　　If .Row < 2 Then Exit Sub
　　If .Column = [F1].Column Then
　　　　With .Offset(, 1)
　　　　　　.FormulaR1C1 = "=VLOOKUP(RC[-1],產品編號!C[-6]:C[-2],2,0)"
　　　　　　.Value = .Value
　　　　　　.Replace "#N/A", "", Lookat:=xlWhole
　　　　　　.Replace "0", ""
　　　　End With
　　ElseIf .Column = [M1].Column Then
　　　　On Error Resume Next
　　　　Application.EnableEvents = False
　　　　For Each xR In Target
　　　　　　MM = Application.Match(xR, Sheets("Sheet1").Range("A:A"), 0)
　　　　　　If IsNumeric(MM) Then xR = Sheets("Sheet1").Range("B" & MM).Value
　　　　Next
　　End If
End With
Application.EnableEvents = True
End Sub

man65boy

回復 2# 准提部林

謝謝準大老師的解題幫忙，完全符合需要，感激不盡^^

GBKEE

回復 3# man65boy
UserForm3,UserForm4
都有

1. Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   
2.   a1 = ListBox1.Value
   
3.   ActiveCell = IIf(ActiveCell = "", a1, ActiveCell & "、" & a1)
   
4. End Sub

複製代碼

表示可複選

建議
UserForm4

1. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   
2.     Dim A As String, Ar As Variant
   
3.     A = UCase(ListBox1.Value)
   
4.     Ar = Filter(Split(ActiveCell, "、"), A)
   
5.     If UBound(Ar) = -1 Then  'ListBox1.Value 不在 ActiveCell中
   
6.         Ar = Application.Evaluate("VLOOKUP(""" & A & """,產品編號!a:b,2,0)")
   
7.         If IsError(Ar) Then  '找不到使用規格或使用規格=""
   
8.             MsgBox A & " 找不到使用規格 或 使用規格 =  """""
   
9.         Else
   
10.             T = IIf(T <> "", T & "、" & MM, MM)
    
11.             ActiveCell = UCase(IIf(ActiveCell = "", A, ActiveCell & "、" & A))
    
12.         End If
    
13.     Else
    
14.         MsgBox A & "已選擇"
    
15.     End If
    
16. End Sub

複製代碼

工作表模組

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Ex Target, False
   
3. End Sub
   
4. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
5.     Ex Target, True
   
6. End Sub
   
7. Private Sub Ex(ByVal Target As Range, Form_Show As Boolean)
   
8.     Application.EnableEvents = False
   
9.     With Target
   
10.         If .Count = 1 And .Row >= 2 Then
    
11.             If .Column = 6 Then
    
12.                編號 .Cells, Sheets("產品編號")
    
13.                If Form_Show Then UserForm4.Show False
    
14.             ElseIf .Column = 13 Then
    
15.                 編號 .Cells, Sheets("Sheet1")
    
16.                 If Form_Show Then UserForm3.Show False
    
17.             End If
    
18.         End If
    
19.     End With
    
20.     Application.EnableEvents = True
    
21. End Sub
    
22. Private Sub 編號(ByVal Target As Range, Sh As Worksheet)
    
23.     Dim Ar As Variant, e As Variant, MM As Variant, T As String
    
24.     Dim Rng As Range
    
25.     Set Rng = Sh.Range("A:B")
    
26.     Ar = Split(Target, "、")
    
27. Ag:
    
28.     For Each e In Ar
    
29.         MM = Application.Evaluate("VLOOKUP(""" & e & """," & Rng.Address(, , , 1, 1) & ",2,0)")
    
30.         If IsError(MM) Then Exit For
    
31.         T = IIf(T <> "", T & "、" & MM, MM)
    
32.     Next
    
33.     If IsError(MM) Then GoTo Er:
    
34.     If Sh.Name = "產品編號" Then
    
35.         Target.Offset(, 1) = T
    
36.     Else
    
37.         Target = T
    
38.     End If
    
39.     Exit Sub
    
40. Er:
    
41.     Ar = Filter(Ar, e, False)
    
42.     Target = Join(Ar, "、")
    
43.     T = ""
    
44.     If e = "" Then Exit Sub
    
45.     GoTo Ag
    
46. End Sub

複製代碼