返回列表 上一主題 發帖

[發問] 輸入資料比對資料表 轉換到別的資料表

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2016-10-10 09:31 | 顯示全部帖子
本帖最後由 GBKEE 於 2016-10-10 10:50 編輯

回復 2# v03586
請問 氮氣必先入氮氣櫃, 其它物件必先入冰箱. 取出(氮氣,冰箱物件),是否都必先入入回溫區

你所需的程式為 1:冰箱                A:存物件(新增資料)                B:取物件入回溫區(資料轉移到回溫區)
                    2:氮氣櫃              A:存氮氣(新增資料)                B:取氮氣,入回溫區(資料轉移到回溫區)
                    3: 出回溫區(刪除資料)
以上程序可否有一 [工號],[層架編號],[Film P/N],[Lot],[回溫後使用期限],[膠紙製造日],[膠紙到期日]的資料表,
做為這些程式的選項整合,用表單(UserForm)來執行

膠紙製造日,膠紙到期日 的資料格式為何用文字而不用日期格式.
距離過期天數: DATE-膠紙到期日 ,排序可用 [膠紙到期日]欄 遞增
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2016-10-11 20:48 | 顯示全部帖子
本帖最後由 GBKEE 於 2016-10-16 13:57 編輯

回復 4# v03586
' Q4.查詢先進先出功能 '使用者選擇要查詢的資料表”下拉式選單”, 輸入料號後,按下﹝查詢﹞按鈕,
       'Listbox 顯示該料號的『前三筆順序』『LOT』『層架位置』
附檔的查詢表單模組的程式
  1. Dim Sh As Worksheet
  2. Private Sub UserForm_Initialize()
  3.     ComboBox1.AddItem "冰箱"
  4.     ComboBox1.AddItem "回溫區"
  5.     ComboBox1.AddItem "氮氣櫃"
  6. End Sub
  7. Private Sub CommandButton1_Click()
  8.     Unload Me
  9. End Sub
  10. Private Sub ComboBox1_Change()
  11.     Dim E As Worksheet
  12.     If ComboBox1.ListIndex > -1 Then
  13.         Set Sh = Sheets("Database-" & ComboBox1)
  14.          '**如有錯誤改用下列程式碼 : 工作表名稱的差異
  15.         'For Each E In Sheets
  16.         '    If InStr(E.Name, ComboBox1) Then
  17.         '        Set Sh = E
  18.         '        Exit For
  19.         '    End If
  20.         'Next
  21.         Ex_Ans Sh    '呼叫程序 傳遞參數
  22.         If Trim(TextBox2) <> "" Then TextBox2_Change
  23.     End If
  24. End Sub
  25. Private Sub TextBox2_Change()
  26.     Dim i As Integer, D As Object, Ar
  27.     Set D = CreateObject("SCRIPTING.DICTIONARY")
  28.     If Trim(TextBox2) <> "" And ComboBox1.ListIndex > -1 Then
  29.         i = 2
  30.         '料號是 Film P/NF ? ->Sh.Cells(i, "C")
  31.         Do While Sh.Cells(i, "a") <> ""
  32.             If Len(Sh.Cells(i, "a")) > 1 And UCase(Sh.Cells(i, "C")) = UCase(Trim(TextBox2)) Then
  33.                 '**Len(Sh.Cells(i, "a")) > 1  因各工作表 前49筆資料 "-" 為何??
  34.                 If Not D.exists(Trim(TextBox2)) Then
  35.                     D(Trim(TextBox2)) = Array(Array(Sh.Cells(i, "B").Text, Sh.Cells(i, "C").Text, Sh.Cells(i, "D").Text))
  36.                 Else
  37.                     Ar = D(Trim(TextBox2))
  38.                     ReDim Preserve Ar(0 To UBound(Ar) + 1)
  39.                     Ar(UBound(Ar)) = Array(Sh.Cells(i, "B").Text, Sh.Cells(i, "C").Text, Sh.Cells(i, "D").Text)
  40.                      D(Trim(TextBox2)) = Ar
  41.                 End If
  42.             End If
  43.             i = i + 1
  44.         Loop
  45.         With TextBox1  '附檔的查詢表單是 TextBox 控制項
  46.             .Text = ""
  47.            .Multi= True
  48.             .Multi屬性 指定控制項是否接受並顯示多行文字。
  49.         End With
  50.           '*********'附檔如有是 ListBox1 控制項
  51.         'With ListBox1
  52.         '    .ColumnCount = 3
  53.         '    .ColumnWidths = "30,50,50"
  54.         '    .Clear
  55.         'End With
  56.         '*********************************
  57.         If D.Count > 0 And D.exists(Trim(TextBox2)) Then
  58.             'ReDim Ar(0)                               '**附檔如有是 ListBox1 控制項
  59.             For i = 0 To UBound(D(Trim(TextBox2)))
  60.             '    ReDim Preserve Ar(0 To i)      '**'附檔如有是 ListBox1 控制項
  61.                 TextBox1 = TextBox1 & IIf(TextBox1 <> "", vbCrLf, "") & Join(D(Trim(TextBox2))(i), ",")
  62.             '    Ar(i) = D(Trim(TextBox2))(i)  '''附檔如有是 ListBox1 控制項
  63.                 If i = 2 Then Exit For  '顯示三筆
  64.             Next
  65.             '********'''附檔如有是 ListBox1 控制項
  66.             'If UBound(Ar) > 0 Then
  67.             '    ListBox1.List = Application.Transpose(Application.Transpose(Ar)) ''附檔如有是 ListBox1 控制項
  68.             'Else
  69.             '    Ar = Ar(0)
  70.             '    With ListBox1
  71.             '        .AddItem
  72.             '        For i = 0 To UBound(Ar)
  73.             '            .List(.ListCount - 1, i) = Ar(i)
  74.             '        Next
  75.             '    End With
  76.             'End If
  77.         End If
  78.     End If
  79. End Sub
複製代碼
Q2-3. 另外「F」欄位是否能內建格式YYYY/MM/DD HH:MM ??
  在工作上寫上 Now 會自動生成YYYY/MM/DD HH:MM 的格式

這程式碼請至於一般模組,可供其它程式使用
  1. Option Explicit
  2. Sub Ex_Ans(Sh As Worksheet)
  3.     Dim St As String, i(1 To 3) As Integer, D As Object, e As Variant, Rng As Range
  4.     'Set Sh = 查詢.Sh
  5.     With Sh
  6.     'With ActiveSheet   ' 可指定為『Database-冰箱』或『Database-回溫區』或『Database-入氮氣櫃』
  7.     '.Activate
  8.         St = "膠紙到期日"
  9.         i(1) = Application.WorksheetFunction.Match(St, Rows(1), 0) '**傳回膠紙到期日的欄位
  10.         
  11.         
  12.                 .Columns(i(1)).TextToColumns Destination:=.Cells(1, i(1)), DataType:=xlDelimited, _
  13.         FieldInfo:=Array(1, 5), TrailingMinusNumbers:=True  '***(文字格式, 轉換為日期)
  14.         
  15.         '   Q1. 放入冰箱後資料會存在『Database-冰箱』資料表
  16.         '       可否幫麻加入計算「I」欄位的距離過期天數, 依照「G」欄位到期日計算
  17.         '        再由“快過期的”在「J」欄位, 顯示優先拿取的順序
  18.   
  19.         ' Q2. 放入回溫區後資料會存在『Database-回溫區』資料表
  20.         '  可否幫麻加入計算「J」欄位的距離過期天數, 依照「F」欄位與距離目前日期計算
  21.         '  再由“快過期的”在「K」欄位, 顯示優先拿取的順序
  22.         
  23.         ' Q3. 放入氮氣櫃後資料會存在『Database-入氮氣櫃』資料表
  24.         '  可否幫麻加入計算「J」欄位的距離過期天數, 依照「F」欄位與距離目前日期計算
  25.         '  再由“快過期的”在「K」欄位, 顯示優先拿取的順序

  27.         
  28.         St = "距離過期天數"
  29.         i(2) = Application.WorksheetFunction.Match(St, Rows(1), 0) '**傳回距離過期天數的欄位
  30.      
  31.         With .Columns(i(2)).Range("a2:a" & .Range("a" & Rows.Count).End(xlUp).Row)  '
  32.         i(3) = i(2) - i(1)
  33.             
  34.              '.FormulaR1C1 = "=IF(ISNUMBER(RC[-2]),RC[-2]-TODAY(), """")"
  35.              .FormulaR1C1 = "=IF(ISNUMBER(RC[-" & i(3) & "]),RC[-" & i(3) & "]-TODAY(), """")"
  36.             
  37.              '**'距離過期天數的欄位寫上公式
  38.             
  39.             .NumberFormatLocal = "G/通用格式"
  40.             .Value = .Value    '**公式轉為值
  41.             Set D = CreateObject("scripting.dictionary") '**字典物件
  42.             For Each e In .Cells
  43.                 If e <> "" Then            '有值的儲存格
  44.                     D(e.Value) = ""        ' e.Value 為字典物件的key
  45.                     If Rng Is Nothing Then
  46.                         Set Rng = e
  47.                     Else
  48.                         Set Rng = Union(Rng, e)  'Union 方法   傳回兩個或多個範圍的合併範圍。
  49.                     End If
  50.                 End If
  51.             Next
  52.             For Each e In Rng
  53.                 For i(1) = 1 To D.Count
  54.                     If e = Application.Small(D.keys, i(1)) Then
  55.                         'e為字典物件key值的第幾 [i(1)] 小的值
  56.                         e.Offset(, 1) = i(1)   '優先拿取順序
  57.                         Exit For
  58.                     End If
  59.                 Next
  60.             Next
  61.         End With
  62.    End With
  63.    
  64.     '排序
  65.     'Q1-1. 輸入放入冰箱功能, 請問是否可以輸入完資料後自動依照「C50」欄位主要排序, 再由「J50」欄位次要排序嗎??

  67.    With Rng.EntireRow
  68.         'Q2-1. 輸入回溫區功能, 請問是否可以輸入完資料後自動依照「C50」欄位主要排序, 再由「J50」欄位次要排序
  69.        '**  key1:=.Cells(1, i(2)), Order1:=1 優先拿取順序為主排序鍵
  70.         .Sort key2:=.Cells(1, "c"), Order1:=1, key1:=.Cells(1, i(2)), Order1:=1, header:=xlNo
  71.         
  72.         'Q5. 『取出回溫區』、『取出氮氣櫃』資料表的拿取順序是否會再次重新排序???
  73.         ' **指裡  資料表內會重新排序
  74.    End With
  75. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2016-10-12 06:16 | 顯示全部帖子
本帖最後由 GBKEE 於 2016-10-12 07:41 編輯

回復 6# v03586

5# 查詢表單模組的程式碼有更新

Sub Ex_Ans(Sh As Worksheet) 放在Module1 (一般模組) 沒錯的

i(1) = Application.WorksheetFunction.Match(St, Rows(1), 0) '**傳回膠紙到期日的欄位
在2003版沒有錯誤的
請改用試試看  i(1) = Sh.Rows(1).Find(St, LookIn:=xlValues, LookAt:=xlWhole).Column '**傳回膠紙到期日的欄位

Q2-2. 輸入回溫區功能比較特別, 輸入LOT時, 可否從『Database-冰箱』資料表, 判斷
                      如果有輸入一樣的LOT, 則從『Database-冰箱』資料表將重覆資料刪除??
  1. Sub 取出回溫區()
  2.    Dim Rng As Range
  3.    '以上程式碼簡略
  4.    ''Inputs(j) = InputBox(" 您現在將要把膠紙從『 回溫區取出 』 " & vbCrLf
  5.    '以上程式碼簡略
  6.    'i = 2
  7.    'NotFound = True
  8.      '  Do
  9.     '    If Inputs(1) = Worksheets("Database-冰箱").Cells(i, "D") Then
  10.     '    *********'『 回溫區取出 』 是在 回溫區 而不是 冰箱  !!!  *****
  11.    
  12.     '        Set Lot_Rng = Worksheets("Database-冰箱").Cells(i, "D")
  13.     '        Worksheets("Database-冰箱").Rows(i).Delete
  14.     '        NotFound = False
  15.     '       Exit Do
  16.     '     End If
  17.     '     i = i + 1
  18.     '  Loop While Worksheets("Database-冰箱").Cells(i, "A") <> ""
  19.    
  20.    '    *********'『 回溫區取出 』 是在 回溫區 而不是 冰箱  !!!  *****
  21.    'Set Rng = Worksheets("Database-冰箱").Range("d:d").Find(Inputs(1), LookIn:=xlValues, LookAt:=xlWhole)
  22.    Set Rng = Worksheets("Database-回溫區").Range("d:d").Find(Inputs(1), LookIn:=xlValues, LookAt:=xlWhole)
  23.    If Not Rng Is Nothing Then
  24.         Rng.EntireRow.Delete
  25.         
  26.         'Q2-2. 輸入回溫區功能比較特別, 輸入LOT時, 可否從『Database-冰箱』資料表, 判斷
  27.         '              如果有輸入一樣的LOT, 則從『Database-冰箱』資料表將重覆資料刪除??
  28.         Set Rng = Worksheets("Database-冰箱").Range("d:d").Find(Inputs(1), LookIn:=xlValues, LookAt:=xlWhole)
  29.         If Not Rng Is Nothing Then Rng.EntireRow.Delete
  30.         
  31.    Else
  32.        MsgBox "找不到資料 < Can't not found data>"
  33.     End If
  34.     End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2016-10-16 14:00 | 顯示全部帖子
本帖最後由 GBKEE 於 2016-10-17 07:22 編輯

回復 11# v03586

附檔 看看有意見再提出

Ex.zip (1.06 MB)
可修改如下 :可是只有一筆資料時它是直著放,不會橫放
  1. ReDim Ar(0 To UBound(D(Trim(TextBox2))))
  2.                 For i = 0 To UBound(D(Trim(TextBox2)))
  3.                     Ar(i) = D(Trim(TextBox2))(i)  '''附檔如有是 ListBox1 控制項
  4.                     If i = 2 Then Exit For  '顯示三筆
  5.                 Next
  6.                 ListBox1.List = Application.Transpose(Application.Transpose(Ar)) ''附檔如有是 ListBox1 控制項
複製代碼
方法一
  1. If D.Count > 0 And D.exists(Trim(TextBox2)) Then
  2.             If UBound(D(Trim(TextBox2))) = 0 Then
  3.                 Ar = D(Trim(TextBox2))(0)
  4.                 With ListBox1
  5.                     .AddItem
  6.                    For i = 0 To UBound(Ar)
  7.                         .List(.ListCount - 1, i) = Ar(i)
  8.                     Next
  9.                 End With
  10.             Else
  11.                 ReDim Ar(0 To 2)
  12.                 For i = 0 To UBound(D(Trim(TextBox2)))
  13.                     Ar(i) = D(Trim(TextBox2))(i)  '''附檔如有是 ListBox1 控制項
  14.                     If i = 2 Then Exit For  '顯示三筆
  15.                 Next
  16.                 ListBox1.List = Application.Transpose(Application.Transpose(Ar)) ''附檔如有是 ListBox1 控制項
  17.               End If
  18.         End If
複製代碼
方法二
  1. If D.Count > 0 And D.exists(Trim(TextBox2)) Then
  2.             'ReDim Ar(0 To UBound(D(Trim(TextBox2))))
  3.             If UBound(D(Trim(TextBox2))) = 0 Then
  4.                 'Ar = D(Trim(TextBox2))
  5.                 With Range("A" & Rows.Count).Resize(, UBound(D(Trim(TextBox2))(0)) + 1)
  6.                     .Value = D(Trim(TextBox2))(0)
  7.                     ListBox1.List = .Value
  8.                     .Cells.Clear
  9.                 End With
  10.             Else
  11.                 ReDim Ar(0 To 2)
  12.                 For i = 0 To UBound(D(Trim(TextBox2)))
  13.                     Ar(i) = D(Trim(TextBox2))(i)  '''附檔如有是 ListBox1 控制項
  14.                     If i = 2 Then Exit For  '顯示三筆
  15.                 Next
  16.                 ListBox1.List = Application.Transpose(Application.Transpose(Ar)) ''附檔如有是 ListBox1 控制項
  17.             End If
  18.         End If
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2016-10-19 06:56 | 顯示全部帖子
回復 13# v03586

不限制格式 Msg = St <> ""
回溫區與氮氣櫃的計算方式不同, 是由F欄位『回溫後使用期限』,判斷距離現在還有多少天到期
可改如下
  1. Sub Ex_Ans()
  2.     Dim St As String, I(1 To 3) As Integer, d As Object, E As Variant, Rng As Range, Ar(), Arr()
  3.     With Sh
  4.         St = "膠紙製造日"
  5.         I(1) = Sh.Rows(1).Find(St, LookIn:=xlValues, LookAt:=xlWhole).Column
  6.         .Columns(I(1)).TextToColumns Destination:=.Cells(1, I(1)), DataType:=xlDelimited, _
  7.             FieldInfo:=Array(1, 5), TrailingMinusNumbers:=True  '***(文字格式, 轉換為日期)
  8.         
  9.         ' **傳回膠紙到期日的欄位  或  回溫後使用期限 的欄位
  10.         If InStr(Sh.Name, "冰箱") Then St = "膠紙到期日" Else St = "回溫後使用期限"
  11.         I(1) = Sh.Rows(1).Find(St, LookIn:=xlValues, LookAt:=xlWhole).Column '**傳回膠紙到期日的欄位
  12.         If St = "回溫後使用期限" Then
  13.             Application.Calculation = xlManual      '活頁簿的計算: 手動
  14.             With .Columns(I(1)).SpecialCells(xlCellTypeConstants)
  15.                 .Cells = .Value                                  '** 文字格式的數字 轉為數值
  16.             End With
  17.             Sh.Calculate               '**Calculate 方法  計算所有開啟的活頁簿、活頁簿中的特定工作表或工作表中指定範圍的儲存格.
  18.             Application.Calculation = xlAutomatic  '活頁簿的計算: 自動
  19.         End If
  20.         If InStr(Sh.Name, "冰箱") Then
  21.             .Columns(I(1)).TextToColumns Destination:=.Cells(1, I(1)), DataType:=xlDelimited, _
  22.             FieldInfo:=Array(1, 5), TrailingMinusNumbers:=True  '***(文字格式, 轉換為日期)
  23.         End If
  24.         St = "距離過期天數"
  25.         I(2) = Sh.Rows(1).Find(St, LookIn:=xlValues, LookAt:=xlWhole).Column
  26.         If .Range("a" & Rows.Count).End(xlUp).Row = 1 Then Exit Sub
複製代碼
3. 查詢先進先出功能 部分查詢料號會無法帶出資料 在11# 有回覆 方法一,方法二
這裡修改
  1. Private Sub ComboBox2_Change()
  2.     Dim Rng As Range, Ar, I As Integer
  3.     With ListBox1
  4.         .Clear
  5.         If ComboBox2.ListIndex = -1 Then Exit Sub
  6.         Ar = Dt(ComboBox2.Value)
  7.         If UBound(Ar) = 0 Then
  8.             .AddItem
  9.             For I = 0 To UBound(Ar(0))
  10.                 .List(0, I) = Ar(0)(I)
  11.             Next
  12.         Else
  13.             .List = Application.Transpose(Application.Transpose(Ar))
  14.         End If
  15.     End With
  16. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2016-10-19 08:51 | 顯示全部帖子
回復 15# v03586
  1. Private Sub TextBox4_Change()
  2.      Dim St As String, Msg As Boolean
  3.         St = Trim(TextBox4)
  4.         Msg = St <> ""
  5.        TheMsg 4, Msg
  6. End Sub
複製代碼
  1. Private Sub Lot_Get()
  2.     Dim I As Long, St As String, B As String, C As String, d As String, Ar(), X As Integer
  3.     Set Dt = CreateObject("ScripTING.DICTIONARY")
  4.     'X = IIf(InStr(ActiveSheet.Name, "冰箱"), 9, 10)
  5.     With Sh
  6.         X = IIf(InStr(.Name, "冰箱"), 9, 10)
  7.         I = ShRow
  8.         Do While .Cells(I, "C") <> ""
  9.             B = .Cells(I, "B"):    C = .Cells(I, "C"):  d = .Cells(I, "D"):    St = Format(.Cells(I, X), "0.0")
  10.             If Not Dt.EXISTS(C) Then
  11.                 Dt(C) = Array(Array(B, C, d, St))
  12.             Else
  13.                 Ar = Dt(C)
  14.                 ReDim Preserve Ar(LBound(Ar) To UBound(Ar) + 1)
  15.                 Ar(UBound(Ar)) = Array(B, C, d, St)
  16.                  Dt(C) = Ar
  17.                  Ar = Dt(C)
  18.             End If
  19.             I = I + 1
  20.         Loop
  21.     End With
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2016-10-19 12:47 | 顯示全部帖子
本帖最後由 GBKEE 於 2016-10-20 05:06 編輯

回復 17# v03586
  1. Private Sub TheMsg(T As Integer, Msg As Boolean)   ''** 程式作用  資料輸入格式的檢查
  2.     '** 乎叫此程式 須帶有 參數1   ,參數2
  3.     Dim St As String
  4.     Text_Ar(T).BackColor = IIf(Msg, 正常色, 錯誤色)
  5.     Text_Msg(T) = Msg
  6.     ComButton_檢查
  7.     If ComButton.Enabled Then ListBox1_Change
  8.     If ComButton.Enabled Then
  9.         ComButton.SetFocus          '**SetFocus 方法 將駐點移到此物件的執行個體上。
  10.     ElseIf Msg Then                     '**輸入格式的正確 下移至下一個控制項
  11. '*****************這裡試著修改 ****************************
  12.         If T > 2 And T <> 5 And T <> UBound(Text_Ar) Then Text_Ar(T + 1).SetFocus
  13. '********************************************************
  14.     End If
  15. End Sub
複製代碼
回溫後使用期限 格式 與 放入時間格式 Private Sub TextBox9_Change() 是相同的
  1. Private Sub TextBox6_Change()
  2.    Dim St, Msg As Boolean, Ar
  3.    '格式  日期&時間
  4.     St = Trim(TextBox6)
  5.     Msg = UBound(Split(St, "/")) = 2 And UBound(Split(St, " ")) = 1 And UBound(Split(St, ":")) = 1: If Not Msg Then GoTo Ne
  6.     Ar = Split(St, " ")
  7.     Msg = IsDate(Ar(0)): If Not Msg Then GoTo Ne
  8.     Msg = IsDate(Ar(1)): If Not Msg Then GoTo Ne
  9.     If Msg Then TextBox6 = Format(TextBox6, 日期時間格式)
  10. Ne:
  11.     TheMsg 6, Msg
  12. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 2016-10-20 05:42 | 顯示全部帖子
本帖最後由 GBKEE 於 2016-10-20 05:54 編輯

回復 19# v03586
回溫使用期限點兩下變成1899年...
修改這裡
  1. Sub 放入冰箱()   'Input 冰箱 (資料存入『Database-冰箱』)
  2.     Set Sh = Sheets("Database-冰箱")
  3.     回溫後使用期限 = Now + 2       '**給值
  4.     Com_Title = " [ 放入冰箱 ]"
  5.     Form_InPut.Show
  6. End Sub
複製代碼
  1. If T = 3 Or T >= 6 And T <> UBound(Text_Ar) Then Text_Ar(T + 1).SetFocus
  2.         '** 1工號 , 2層架編號 , 4LOT, 5PCS  **不設格式不跳到下一輸 入控制項
  3.         '**3Film P/N , 6回溫後使用期限, 7膠紙製造日 8 膠紙到期日 **'跳到下一輸 入控制項
  4.         '** 9 放入時間=>Text_Ar(T + 1).SetFocus 會有錯誤的
複製代碼
工號 跟 層架編號....   解除限制
  1. Private Sub TextBox1_Change()          '** 控制項有變動 : 程式作用  資料格式 的檢查
  2.      '**不限制格式
  3.      TheMsg 1, Trim(TextBox1) <> ""   '不限制格式
  4. End Sub
複製代碼
設定條碼格式
  1. Private Sub TextBox7_Change()
  2.     '格式  條碼 8 位數
  3.     Dim St(1 To 2) As String, Msg As Boolean, Ar
  4.     St(1) = Trim(TextBox7)
  5.     Msg = Len(St(1)) = 8 And IsNumeric(St(1)): If Not Msg Then GoTo Ne
  6.     St(2) = Mid(St(1), 1, 4) & "/" & Mid(St(1), 5, 2) & "/" & Mid(St(1), 7, 2)
  7.     Msg = IsDate(St(2)): If Not Msg Then GoTo Ne         '**日期正確
  8.     Msg = DateValue(St(2)) < Date: If Not Msg Then GoTo Ne    '**膠紙製造日必小於當日
  9. Ne:
  10.     TheMsg IIf(Label6.Enabled, 7, 6), Msg
  11. End Sub
  12. Private Sub TextBox8_Change()
  13.      '格式  條碼 8 位數
  14.     Dim St(1 To 3) As String, Msg As Boolean, Ar
  15.    St(1) = Trim(TextBox8)
  16.     Msg = Len(St(1)) = 8 And IsNumeric(St(1)): If Not Msg Then GoTo Ne
  17.     St(2) = Mid(St(1), 1, 4) & "/" & Mid(St(1), 5, 2) & "/" & Mid(St(1), 7, 2)  '膠紙到期日
  18.     Msg = IsDate(St(2)): If Not Msg Then GoTo Ne
  19.     Msg = Text_Msg(IIf(Label6.Enabled, 7, 6)): If Not Msg Then GoTo Ne '膠紙製造日是否正確
  20.     St(3) = Trim(TextBox7)
  21.     St(3) = Mid(St(3), 1, 4) & "/" & Mid(St(3), 5, 2) & "/" & Mid(St(3), 7, 2)  '**'膠紙製造日
  22.     Msg = DateValue(St(2)) > DateValue(St(3))                       '**膠紙到期日必大於膠紙製造日
  23. Ne:
  24.     TheMsg IIf(Label6.Enabled, 8, 7), Msg
  25. End Sub
  26. '**設定條碼格式 後需修改
  27. Private Sub ComButton_Click()          '**控制項的事件 (按下控制項)
  28.     Dim i As Integer, XR As Integer
  29.     If MsgBox(Join(Text_Ar, vbLf), vbYesNo, "   ** 確定 " & Com_Title & "  **") = vbYes Then
  30.         '**Join 函數 傳回一個字串 , 該字串是透過連結某個陣列中的多個子字串而建立的
  31.         XR = Application.CountA(Sh.[A:A])
  32.         With Sh.Range("A" & XR).Offset(1)
  33.             For i = 1 To UBound(Text_Ar)               '**UBound 函數 傳回 Long值，表示指定陣列某維最大可使用的陣列索引。
  34.                  If InStr(Sh.Name, "冰箱") And (i = 6 Or i = 7) Then
  35.                     .Cells(1, i) = Mid(Text_Ar(i), 1, 4) & "/" & Mid(Text_Ar(i), 5, 2) & "/" & Mid(Text_Ar(i), 7, 2)
  36.                  ElseIf InStr(Sh.Name, "冰箱") = 0 And (i = 7 Or i = 8) Then
  37.                     .Cells(1, i) = Mid(Text_Ar(i), 1, 4) & "/" & Mid(Text_Ar(i), 5, 2) & "/" & Mid(Text_Ar(i), 7, 2)
  38.                  Else
  39.                     .Cells(1, i) = UCase(Text_Ar(i).Text)  '**UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  40.                 End If
  41.             Next
  42.         End With
  43.         DataBase_Show
  44.     End If
  45.     ListBox1_Change
  46. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
9#
發表於 2016-10-23 10:38 | 顯示全部帖子
回復 21# v03586

附檔試試看

Ex.zip (878.16 KB)
   

[條碼] 沒接觸過,如有問題,我不知.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 【是否發揮了良能？】人間壽命因為短暫，才更顯得珍貴。難得來一趟人間，應問是否為人間發揮了自己的良能，而不要一味求長壽。
返回列表 上一主題