程式碼整合

vinejason

平安
以下的程式碼是我用土法煉鋼的方式做的
目前正常運作中
請高手看看可否整合 ?
謝謝

Private Sub Worksheet_Change(ByVal Target As Range) '交互查詢
Application.Calculation = xlCalculationManual '關閉自動運算
ActiveSheet.Unprotect Password:=3551 '撤消工作表保護並取消密碼
Dim i%, x(), y(), xy()
Dim F1 As Range
Dim rn As Range, tt As Range
On Error Resume Next
Application.EnableEvents = False
  With Sheets("廠商資料")
               Set F1 = .Columns(1).Find([C3])
               [c4] = .Cells(F1.Row, 2)
               [c5] = .Cells(F1.Row, 7)
              End With      
  Application.EnableEvents = True

Set T = Target
For Each tt In T
If tt.Column = 2 Then
   Set rn = Sheet1.[c:c].Find(tt, , , 1)
   If Not rn Is Nothing And tt.Offset(, 1) <> rn.Offset(, -1) Then
      tt.Offset(, 1) = rn.Offset(, -1).Value
      'tt.Offset(, 3) = rn.Offset(, 4).Value
     ' tt.Offset(, 6) = rn.Offset(, 1).Value
   End If
ElseIf tt.Column = 3 Then
   Set rn = Sheet1.[b:b].Find(tt, , , 1)
   If Not rn Is Nothing And tt.Offset(, -1) <> rn.Offset(, 1) Then
      tt.Offset(, -1) = rn.Offset(, 1).Value
     ' tt.Offset(, 2) = rn.Offset(, 5).Value
     ' tt.Offset(, 5) = rn.Offset(, 2).Value
   End If
End If
Next tt
Set T = Nothing: Set tt = Nothing

  Set U = Target  
  Set dbsheet = Sheets("天恩書目")
  Set myrange = dbsheet.Range("c2:c2020")
  For Each cell In U  
    rw = cell.Row '列
    cl = cell.Column '欄
    Select Case cl
      Case 2, 3
        If cell = "" And rw > 6 Then  '品名被清空,不顯示
             Application.EnableEvents = False
             Range(Cells(rw, 7), Cells(rw, 16)).ClearContents
             Application.EnableEvents = True
         ElseIf cell <> "" And rw > 6 And cl = 2 Then '顯示資料,即顯示
             Set m = myrange.Find(cell, LookIn:=xlValues)
             Application.EnableEvents = False
             If Not m Is Nothing Then
                 rw2 = m.Row
              Cells(rw, 8) = dbsheet.Cells(rw2, 12)
              Cells(rw, 9) = dbsheet.Cells(rw2, 14)
              Cells(rw, 7) = dbsheet.Cells(rw2, 15)
              Cells(rw, 10) = dbsheet.Cells(rw2, 19)
              Cells(rw, 11) = dbsheet.Cells(rw2, 8)
              Cells(rw, 12) = dbsheet.Cells(rw2, 23)
              Cells(rw, 13) = dbsheet.Cells(rw2, 24)
              Cells(rw, 14) = dbsheet.Cells(rw2, 29)
               Cells(rw, 15) = dbsheet.Cells(rw2, 10)
               Cells(rw, 16) = dbsheet.Cells(rw2, 11)
              
             End If
            Set U = Nothing
           
             Application.EnableEvents = True
        End If
      Case 7, 8, 9, 10, 11, 12, 13, 14, 15, 16
        If rw > 6 Then '修改資料
             Set m = myrange.Find(Cells(rw, 2), LookIn:=xlValues)
             Application.EnableEvents = False
             If Not m Is Nothing Then
                 rw2 = m.Row
                 
              dbsheet.Cells(rw2, 12) = Cells(rw, 8)
              dbsheet.Cells(rw2, 14) = Cells(rw, 9)
              dbsheet.Cells(rw2, 15) = Cells(rw, 7)
              dbsheet.Cells(rw2, 19) = Cells(rw, 10)
              dbsheet.Cells(rw2, 8) = Cells(rw, 11)
              dbsheet.Cells(rw2, 23) = Cells(rw, 12)
              dbsheet.Cells(rw2, 24) = Cells(rw, 13)
              dbsheet.Cells(rw2, 29) = Cells(rw, 14)
              dbsheet.Cells(rw2, 10) = Cells(rw, 15)
              dbsheet.Cells(rw2, 11) = Cells(rw, 16)
              
             End If
          dbsheet.Close
          myrange.Quit
          Set U = Nothing
          Set dbsheet = Nothing
            Set myrange = Nothing
            
             Application.EnableEvents = True
        End If
      
        
    End Select
    Next cell
   
     On Error GoTo 1
  Set V = Target
  If V.Count > 1 Then End
  If V.Address Like "*$A$2*" Then
    x = Array("A", "B", "C")
    y = Array("A倉庫", "B倉庫", "C倉庫")
    If V = "進  貨  單" Or V = "贈  書  單" Or V = "發  行  者  取  書  單" Or V = "取  貨  單" Then
      xy = x
    Else
      xy = y
    End If
    With [E7:E32].Validation
      .Delete
      .Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=Join(xy, ",")
    End With
  End If

dbsheet.Close
myrange.Quit
Set V = Nothing
Set dbsheet = Nothing
Set myrange = Nothing
  Application.Calculate                                       '恢復自動運算
    Application.Calculation = xlCalculationAutomatic   '恢復自動運算
  
     Application.StatusBar = 就緒
   Application.EnableEvents = True
1:

Set dbsheet = Nothing
Set myrange = Nothing
  Application.Calculate                                       '恢復自動運算
    Application.Calculation = xlCalculationAutomatic   '恢復自動運算
   
       Application.StatusBar = 就緒
   Application.EnableEvents = True

   End Sub

GBKEE

回復 1# vinejason

不用 On Error Resume Next 你的程式不可行

1. dbsheet.Close  'Worksheet 沒有 Close的方法
   
2.           myrange.Quit  'Range 沒有Quit的方法

複製代碼

沒有附檔說明要整合什麼,看的眼花了.