麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] TextBox顯示自動編號問題請教﹖ [打印本頁]

作者: ann.liu 時間: 2014-10-28 22:44 標題: TextBox顯示自動編號問題請教﹖

請教各位大大：
是否可以在TextBox顯示A:A最後一個編號再+1
點選CommandButton1後將TextBox顯示的資料COPY到工作表1
附件如下：
[attach]19419[/attach][attach]19420[/attach]

作者: ann.liu 時間: 2014-10-28 23:28 標題: Label日期顯示格式問題請教

請問各位大大：
VLOOKUP參照編號產生日期，
但日期的格式與工作表1的格式不同，
請問是否可以改成2014/9/5的格式顯示。
[attach]19421[/attach]
[attach]19422[/attach]

作者: luhpro 時間: 2014-10-28 23:46

請問各位大大：
VLOOKUP參照編號產生日期，
但日期的格式與工作表1的格式不同，
請問是否可以改成2014/9 ...
ann.liu 發表於 2014-10-28 23:28

用 Format 函數就可以解決 :
...
Me.lbl建立日期 = Format(Application.VLookup(Me.cmb編號, Worksheets("工作表1").[編號], 2, 0) , "yyyy/m/d")
...

作者: luhpro 時間: 2014-10-29 00:27

請教各位大大：
是否可以在TextBox顯示A:A最後一個編號再+1
點選CommandButton1後將TextBox顯示的資料COP ...
ann.liu 發表於 2014-10-28 22:44

Module1 :

Public iMax%

複製代碼

ThisWorkBook :

Private Sub Workbook_Open()
Dim lRow&
Dim sStr$
iMax = 0
lRow = 2
Do While Cells(lRow, 1) <> ""
sStr = Cells(lRow, 1)
iNum = Val(Mid(sStr, InStr(1, sStr, "-") + 1))
If iNum >= iMax Then iMax = iNum
lRow = lRow + 1
Loop
UserForm1.Show
End Sub

複製代碼

UserForm1 :

Private Sub cb輸入_Click()
With Sheets("工作表1")
If Application.WorksheetFunction.CountIf(.Range("a:a"), txt編號) > 0 Then
MsgBox "編號已存在!", vbCritical, "錯誤"
Exit Sub
End If
With .Range("A65536").End(xlUp)
.Range("A2") = txt編號.Text
iMax = iMax + 1
txt編號.Text = "AL-" & Right("000" & iMax + 1, 3)
End With
End With
End Sub
Private Sub UserForm_Initialize()
txt編號.Text = "AL-" & Right("000" & iMax + 1, 3)
End Sub

複製代碼

[attach]19423[/attach]

作者: GBKEE 時間: 2014-10-29 08:51

回復 2# luhpro
另一寫法
UserForm模組

Option Explicit
Dim D As Object
Private Sub UserForm_Initialize()
txt編號 = 編號
End Sub
Private Sub cb輸入_Click()
With Sheets("工作表1")
If Application.CountIf(.Range("a:a"), txt編號) > 0 And txt編號 <> "" Then
MsgBox "編號已存在!", vbCritical, "錯誤"
Exit Sub
ElseIf UBound(Split(txt編號, "-")) = 0 Or txt編號 = "" Then
MsgBox "編號格式錯誤!", vbCritical, "錯誤"
Exit Sub
ElseIf UCase(txt編號) <> "AL-" & Format(Application.Max(D.KEYS) + 1, "000") Then
MsgBox txt編號 & " 需是 " & "AL-" & Format(Application.Max(D.KEYS) + 1, "000"), vbCritical, "錯誤"
Exit Sub
End If
.Range("A65536").End(xlUp).Cells(2) = txt編號
D(Application.Max(D.KEYS) + 1) = ""
End With
End Sub
Private Sub CommandButton2_Click() 'cb輸入後,可繼續 + 1
txt編號 = "AL-" & Format(Application.Max(D.KEYS) + 1, "000")
End Sub
Private Function 編號() As String
Dim E As Range
Set D = CreateObject("SCRIPTING.DICTIONARY")
For Each E In 工作表1.Range("A:A").SpecialCells(xlCellTypeConstants)
If UBound(Split(E, "-")) > 0 Then D(Val(Split(E, "-")(1))) = ""
Next
If D.Count = 0 Then
編號 = "AL-001"
D(0) = ""
Else
編號 = "AL-" & Format(Application.Max(D.KEYS) + 1, "000")
End If
End Function

複製代碼

作者: ann.liu 時間: 2014-10-31 09:36

[attach]19432[/attach][attach]19432[/attach]回復 5# GBKEE

感謝luhpro與GBKEE大大的回覆，二位大大的方法都是可以使用。

另外要請教luhpro大大
1.如果我有4個UserForm 都要自動編號，編號都要自動帶出，
我重新製作另外三個表單，但號碼會亂跳，不知錯誤在那，請大大指教﹖

2.我做了4個按鈕點選需要的表單，不要開始excel就自動跳出視窗，
請問大大要如何編寫呢﹖
3.日期顯示可以加上時間嗎﹖
Me.lbl建立日期 = Format(Application.VLookup(Me.cmb編號, Worksheets("工作表1").[編號], 2, 0) , "yyyy/m/d")
附檔： [attach]19432[/attach]
另外要請教GBKEE大大
表單如果要連續輸入好幾筆，是否可以自動進位呢
1. Private Sub CommandButton2_Click() 'cb輸入後,可繼續 + 1
2. txt編號 = "AL-" & Format(Application.Max(D.KEYS) + 1, "000")
3. End Sub

作者: GBKEE 時間: 2014-10-31 09:54

回復 6# ann.liu

表單如果要連續輸入好幾筆，是否可以自動進位呢
試試看

Private Sub cb輸入_Click()
With Sheets("工作表1")
If Application.CountIf(.Range("a:a"), txt編號) > 0 And txt編號 <> "" Then
MsgBox "編號已存在!", vbCritical, "錯誤"
Exit Sub
ElseIf UBound(Split(txt編號, "-")) = 0 Or txt編號 = "" Then
MsgBox "編號格式錯誤!", vbCritical, "錯誤"
Exit Sub
ElseIf UCase(txt編號) <> "AL-" & Format(Application.Max(D.KEYS) + 1, "000") Then
MsgBox txt編號 & " 需是 " & "AL-" & Format(Application.Max(D.KEYS) + 1, "000"), vbCritical, "錯誤"
Exit Sub
End If
.Range("A65536").End(xlUp).Cells(2) = txt編號
D(Application.Max(D.KEYS) + 1) = ""
txt編號 = "AL-" & Format(Application.Max(D.KEYS), "000")
End With
End Sub

複製代碼

作者: ann.liu 時間: 2014-10-31 11:11

GBKEE大大
試後還是不能自動進號

作者: luhpro 時間: 2014-11-2 22:49

本帖最後由 luhpro 於 2014-11-2 22:52 編輯

1.如果我有4個UserForm 都要自動編號，編號都要自動帶出，
我重新製作另外三個表單，但號碼會亂跳，不知錯誤在那，請大大指教﹖
2.我做了4個按鈕點選需要的表單，不要開始excel就自動跳出視窗，
請問大大要如何編寫呢﹖
3.日期顯示可以加上時間嗎﹖
Me.lbl建立日期 = Format(Application.VLookup(Me.cmb編號, Worksheets("工作表1").[編號], 2, 0) , "yyyy/m/d") ...
ann.liu 發表於 2014-10-31 09:36

我重做了.
1. 刪除開啟表格工作表, 刪除其他多的 UserForm, 只保留一個 UserForm 實現相關功能, 保留日後新增工作表的彈性, 只要名稱開頭為 "工作表" 就會自動加入選擇序列, 目前可在 Userform 上直接切換工作表與增號.
2. 啟動 UserForm 按鈕放在上方功能表區中說明的右邊, 那個按鈕點一下即可開啟 UserForm.
3. 因為你沒有說明日期時間取值的標準,我直接帶入目前時間.
4. 在工作表選單切換時, 各工作表中 B1 的值會帶到姓名標題欄, 保留彈性調整顯示的可能性.
5. 新增的工作表須自行輸入 A1,B1,C1 的標題名稱, A2 則輸入新的編號
6. 部分地方可能還有 BUG ,時間不夠來不及一一測試.
ufTar (UserForm)

Private Sub cbSheet_Change()
Dim bNFind As Boolean
Dim vA
bNFind = True
For Each vA In ufTar.cbSheet.List
If vA = ActiveSheet.Name Then bNFind = False
Next
If bNFind Then GetSht
SetForm
End Sub
Private Sub cb輸入2_Click()
Dim sStr$
sStr = CStr(cbSheet)
With Sheets(sStr)
If Application.WorksheetFunction.CountIf(.Range("a:a"), txt編號2) > 0 Then
MsgBox "編號已存在!", vbCritical, "錯誤"
Exit Sub
End If
With .Range("A65536").End(xlUp)
.Range("A2") = txt編號2
.Range("B2") = txt姓名1
.Range("C2") = txt日期1
iMax(vNo(vSh(sStr))) = iMax(vNo(vSh(sStr))) + 1
txt編號2.Text = vSh(sStr) & "-" & Right("0000" & iMax(vNo(vSh(sStr))) + 1, 4)
End With
End With
End Sub
Private Sub txt日期1_Change()
Dim sStr$
sStr = IIf(Hour(Now) > 12, "下午", "上午")
txt日期1 = Format(Now, "yyyy/m/d " & sStr & Format(Now, " h:mm"))
End Sub
Public Sub UserForm_Initialize()
Dim sStr$
Dim vA
GetSht
sStr = ActiveSheet.Name
With cbSheet
.Clear
For Each vA In vSh
.AddItem vA
If vA = sStr Then .Value = sStr
Next
If .Value = "" Then
.ListIndex = 0
End If
End With
SetForm
End Sub
Private Sub SetForm()
Dim sStr$
Application.CommandBars(1).Controls(iBtn).Visible = False
sStr = CStr(cbSheet)
Sheets(sStr).Select
txt編號2.Text = vSh(sStr) & "-" & Right("0000" & iMax(vNo(vSh(sStr))) + 1, 4)
Label2.Caption = Sheets(sStr).[B1]
txt日期1 = Format(Now, "yyyy/m/d " & sStr & Format(Now, " h:mm"))
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.CommandBars(1).Controls(iBtn).Visible = True
End Sub

複製代碼

ThisWorkBook

Private Sub Workbook_Open()
SetButton (False)
GetSht
SetButton (True)
End Sub
Private Sub SetButton(bSw As Boolean)
Dim sName$
Dim bNFind As Boolean
Dim vC, tcbLdData
sName = "開啟表格"
If Not bSw Then
For Each vC In Application.CommandBars(1).Controls
With vC
If .Caption = sName Then
.Visible = False
iBtn = .Index
End If
End With
Next
Else
bNFind = True
For Each vC In Application.CommandBars(1).Controls
With vC
If .Caption = sName Then
bNFind = False
.Visible = True
iBtn = .Index
End If
End With
Next
If bNFind Then
Set tcbLdData = Application.CommandBars(1).Controls.Add(Type:=msoControlButton)
With tcbLdData
.Caption = sName
.FaceId = 2778
.OnAction = "ShowForm"
iBtn = .Index
End With
End If
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars(1).Controls(iBtn).Delete
End Sub

複製代碼

Module1

Public iMax%(), iBtn%
Public vNo, vSh
Option Explicit
Public Sub ShowForm()
On Error GoTo ErrShowForm
With ufTar
If .Visible = False Then .Show
End With
On Error GoTo 0
Exit Sub
ErrShowForm:
Select Case Err.Number
Case 424 ' 此處需要物件
ufTar.Show
Case 13 ' 型態不符合
Set vSh = CreateObject("Scripting.Dictionary")
Set vNo = CreateObject("Scripting.Dictionary")
ReDim iMax(0)
Case Else
On Error GoTo 0
End Select
Resume
End Sub
Public Sub GetSht()
Dim iNum%
Dim lRow&
Dim sStr$
Dim bNFind1 As Boolean, bNFind2 As Boolean
Dim vA, vB
On Error GoTo ErrGetSht
bNFind2 = False
For Each vA In Worksheets
bNFind1 = True
For Each vB In vSh
If vB = vA.Name Then
bNFind1 = False
Exit For
End If
Next
If bNFind1 Then
bNFind2 = True
Exit For
End If
Next
If Not bNFind2 Then
bNFind2 = False
For Each vA In vSh
bNFind1 = True
For Each vB In Worksheets
If vB.Name = vA Then
bNFind1 = False
Exit For
End If
Next
If bNFind1 Then
bNFind2 = True
Exit For
End If
Next
End If
If bNFind2 Then
GoSub SetSel
End If
On Error GoTo 0
Exit Sub
SetSel:
Set vSh = CreateObject("Scripting.Dictionary")
Set vNo = CreateObject("Scripting.Dictionary")
ReDim iMax(0)
For Each vA In Worksheets
With vA
If .Name Like "工作表*" Then
If .[A2] = "" Then .[A2] = "xxx-0001"
sStr = Left(.[A2], InStrRev(.[A2], "-") - 1)
vSh(CStr(.Name)) = sStr
ReDim Preserve iMax(UBound(iMax, 1) + 1)
iMax(UBound(iMax, 1)) = 0
vNo(sStr) = UBound(iMax, 1)
lRow = 2
Do While .Cells(lRow, 1) <> ""
sStr = .Cells(lRow, 1)
iNum = Val(Mid(sStr, InStrRev(sStr, "-") + 1))
If iNum >= iMax(UBound(iMax, 1)) Then iMax(UBound(iMax, 1)) = iNum
lRow = lRow + 1
Loop
End If
End With
Next
Return
ErrGetSht:
Select Case Err.Number
Case 424 ' 此處需要物件
Set vSh = CreateObject("Scripting.Dictionary")
Set vNo = CreateObject("Scripting.Dictionary")
ReDim iMax(0)
Case 13 ' 型態不符合
Set vSh = CreateObject("Scripting.Dictionary")
Set vNo = CreateObject("Scripting.Dictionary")
ReDim iMax(0)
Case Else
On Error GoTo 0
End Select
Resume
End Sub

複製代碼

[attach]19462[/attach]

作者: ann.liu 時間: 2014-11-4 20:02

感謝luhpro大大：
你的寫法測試後，真是讓我太佩服了，雖然程式不是很了解，
但會努力的研究，檔案就先收下，慢慢研究了，感恩。

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