GBKEE

回復 1# lancerlot1980
檔案資料量沒有很多，但是就已經2.6MB了，是公式太多下面的程式碼可替代公式.

1. Private Sub Workbook_Open() 'ThisWorkbook物件的程式碼
   
2.     Dim E As Range
   
3.     With Sheets("下拉選單").UsedRange.SpecialCells(xlCellTypeConstants)
   
4.         For Each E In .Areas
   
5.             E.CreateNames Top:=True  '定義名稱 出貨狀態 顧客來源 出貨方式 ...
   
6.         Next
   
7.     End With
   
8. End Sub

複製代碼

1. '201401 工作表物件的程式碼
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     Dim Rng As Range
   
4.     If Target.Cells(1).Column < 4 Then Exit Sub  'A欄-C欄
   
5.     Application.EnableEvents = False
   
6.     With Target.Cells(1)
   
7.         Select Case .Row
   
8.             Case 6  '輸入 郵遞區號
   
9.                 Set Rng = Sheets("郵遞區號").[a:a].Find(Target.Cells(1), lookat:=xlWhole)
   
10.                 If Not Rng Is Nothing Then
    
11.                     Target.Cells(1).Offset(1) = Rng.Offset(, 1)
    
12.                 Else
    
13.                     Target.Cells(1).Offset(1) = ""
    
14.                 End If
    
15.             Case Is >= 23, 13      '輸入 數量
    
16.                 Cells(13, .Column) = Application.WorksheetFunction.SumProduct([C23:C2022], [C23:C2022].Offset(, .Column - 3))
    
17.                 With Cells(17, .Column)
    
18.                     If Cells(13, .Column) <= Application.Sum([C14:C15].Offset(, .Column - 3)) Then
    
19.                         .Cells = Cells(16, .Column)
    
20.                     Else
    
21.                     .Cells = Cells(13, .Column) - Application.Sum([C14:C15].Offset(, .Column - 3)) + Cells(16, .Column)
    
22.                     End If
    
23.                 End With
    
24.             Case 14 To 17       '輸入 折扣A, 折扣B,運費
    
25.                 With Cells(17, .Column)
    
26.                     If Cells(13, .Column) <= Application.Sum([C14:C15].Offset(, .Column - 3)) Then
    
27.                         .Cells = Cells(16, .Column)
    
28.                     Else
    
29.                     .Cells = Cells(13, .Column) - Application.Sum([C14:C15].Offset(, .Column - 3)) + Cells(16, .Column)
    
30.                     End If
    
31.                 End With
    
32.         End Select
    
33.     End With
    
34.     Application.EnableEvents = True
    
35. End Sub
    
36. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
37.     Dim S As String
    
38.     Cells.Validation.Delete   '刪除 所有的儲存格的驗證(下拉選單)
    
39.     With Target.Cells(1)
    
40.         If .Column >= 4 Then
    
41.             Select Case .Row
    
42.                 Case 2
    
43.                     S = "=出貨狀態"
    
44.                 Case 9
    
45.                     S = "=顧客來源"
    
46.                 Case 19
    
47.                     S = "=出貨方式"
    
48.             End Select
    
49.         End If
    
50.         If Target.Cells(1).Address = "$C$1" Then S = "=" & Range("D1", [D1].End(xlToRight)).Address   '序號 的範圍
    
51.         If S <> "" Then
    
52.             With .Validation         '儲存格的驗證(下拉選單)
    
53.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=S '指定公式
    
54.             End With
    
55.         End If
    
56.     End With
    
57. End Sub

複製代碼

1. Option Explicit
   
2. Private Sub Autoform_Click()
   
3.     '開始製作
   
4.     Dim Rng As Range, E As Range
   
5.     With Sheets("201401")
   
6.         Set Rng = .Range("D1", .[D1].End(xlToRight)).Find(.[C1], lookat:=xlWhole)
   
7.     End With
   
8.     If Rng Is Nothing Then MsgBox Rng & "找不到": Exit Sub
   
9.     If Application.Sum(Rng.Range("A23:A2022")) <= 0 Then MsgBox Rng & "沒有輸入": Exit Sub
   
10.     With Sheets("出貨單")
    
11.         .Range("B3:B6,D3:D6,F3:F6,A8:F" & .Rows.Count) = ""
    
12.         .Range("B3:B5") = Rng.Range("A3:A5").Value              '複製基本資料
    
13.         .Range("B6") = Rng.Range("A7") & Rng.Range("A8")        '複製地址
    
14.         .Range("D3") = Rng.Range("A10")                         '複製訂貨日期
    
15.         .Range("D4") = Rng.Range("A18")                         '複製預期出貨日
    
16.         .Range("D5") = Rng.Parent.Range("A2") & Rng             '複製出貨序號
    
17.         .Range("D6").Value = Rng.Range("A20")                   '複製物流編號
    
18.         .Range("F3:F6") = Rng.Range("A14:A17").Value            '複製計算金額
    
19.         For Each E In Rng.Range("A23:A2022").SpecialCells(xlCellTypeConstants, xlNumbers) '有數字的儲存格
    
20.             With .Cells(Rows.Count, 1).End(xlUp).Offset(1)      '出貨單 A欄:由最後一列往上到有資料儲存格.Offset(1)
    
21.                 .Cells(1, 1) = E.Offset(, -E.Column + 1)        '品項
    
22.                 .Cells(1, 2) = E.Offset(, -E.Column + 2)        '品名
    
23.                 .Cells(1, 3) = E.Offset(, -E.Column + 3)        '金額
    
24.                 .Cells(1, 4) = E                                '數量
    
25.                 .Cells(1, 5) = .Cells(1, 3) * .Cells(1, 4)      '小計
    
26.             End With
    
27.         Next
    
28.         .PageSetup.PrintArea = "$A1:$F$" & .Cells(Rows.Count, 1).End(xlUp).Row  '設定印列範圍印表
    
29.         .PrintOut  '印表
    
30.     End With
    
31. End Sub

複製代碼