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

標題: [發問] 請教新增表單編號問題 [打印本頁]

作者: afu9240 時間: 2017-12-13 11:14 標題: 請教新增表單編號問題

版大各位vba高手:

想請教在表單按--新增後---表單號碼是否可產生成單號"009", 附上圖片及檔案,,,,[attach]28112[/attach][attach]28112[/attach][attach]28112[/attach][attach]28113[/attach]求協助!!謝謝

作者: GBKEE 時間: 2017-12-13 14:02

回復 1# afu9240

TextBox6.Value = Format(Worksheets("叫修明細").Cells(x, 1) + 1, "000")

複製代碼

作者: afu9240 時間: 2017-12-14 10:27

回復 2# GBKEE

G大版主您好小妹可以再請教一個問題

附件是一個訓練履歷表,為何我用名字mark查詢後,listbox1會出現資料,但在clear後,再輸入mark查詢卻無法出現資料,輸入別得名字也一樣, 是否可解惑!!感恩謝謝

[attach]28123[/attach]
[attach]28124[/attach]

作者: GBKEE 時間: 2017-12-14 14:39

Private Sub CommandButton4_Click() 'clear
TextBox11.Text = ""
TextBox10.Text = ""
TextBox1.Text = ""
Image1.Picture = LoadPicture
With ListBox1
'If Selection.Count > 7 Then
' .List = Selection.Value
' Else
.Clear
' .AddItem Selection
' End If
' .ColumnCount = Selection.Columns.Count
End With
End Sub

複製代碼

回復 4# afu9240

作者: afu9240 時間: 2017-12-18 15:49

回復 5# GBKEE

G大您好

小妹卡住了,關鍵字搜尋要如何帶出到"工作表2"(只要跟這字有關係的都要帶出),真的很抱歉想[attach]28138[/attach][attach]28138[/attach]跟您請益!!!!

作者: Hsieh 時間: 2017-12-18 17:53

Private Sub CommandButton2_Click()
Dim A As Range, Rng As Range
If TextBox1.Text = "" Then
MsgBox "請輸入正確的值"
Else
Application.ScreenUpdating = False
Worksheets("工作表2").Range("A:G").Clear
With Worksheets("工作表1")
Set A = .Cells.Find(TextBox1, Lookat:=xlPart)
If Not A Is Nothing Then
first = A.Address
Do
If Rng Is Nothing Then
Set Rng = .Cells(A.Row, 1).MergeArea
Else
Set Rng = Union(Rng, .Cells(A.Row, 1).MergeArea)
End If
Set A = .Cells.FindNext(A)
Loop While Not A Is Nothing And A.Address <> first
Rng.EntireRow.Copy Sheets("工作表2").[A1]
Else
MsgBox "無符合資料"
End If
End With
End If
Application.ScreenUpdating = True
End Sub

複製代碼

回復 7# afu9240

作者: afu9240 時間: 2018-1-2 15:11

回復 8# Hsieh

感謝版大,,,長知識 [attach]28192[/attach][attach]28192[/attach][attach]28192[/attach][attach]28192[/attach]

請教一下附件, 如何用vba寫死函數公式, 爬文跟在論壇內找了找都沒有相關文章,是否可協助解惑!小妹感激

作者: GBKEE 時間: 2018-1-2 19:07

回復 9# afu9240

是這樣嗎?

Sub old() '年齡自動代入
Dim x1, x2, i As Integer
Cells(1, 5) = Now()
'x1 = YearFrac(Now(), 0) '這裡錯誤
'x1 = Application.WorksheetFunction.YearFrac(Now(), 0)
X = 2
Do
Cells(X, "C") = "=AGE(RC[-1])" 'RC[-1] R1C1的格式參照法
X = X + 1
Loop Until Cells(X, "B") = ""
End Sub
'***'Module1(一般模組)的程式碼
'**自訂函數
Function AGE(D1)
AGE = "#NA"
Application.Volatile (False)
If IsDate(D1) And D1 > 0 Then AGE = DateDiff("YYYY", D1, Date)
End Function

複製代碼

作者: afu9240 時間: 2018-1-3 09:58

回復 8# GBKEE

感謝G大回復..G大真的太厲害了
想請問G大是否可以計算到小數點兩位數因為現在好像都是取整數

作者: GBKEE 時間: 2018-1-3 12:21

回復 9# afu9240

Function AGE(D1 As Range) 'Module1(一般模組)
AGE = "#NA"
Application.Volatile (False)
If IsDate(D1) And D1 > 0 Then
AGE = DateDiff("m", D1, Date)
AGE = Round(Int(AGE / 12), 0) & "." & AGE - (Round(Int(AGE / 12), 0) * 12) ' 剩餘月份的小數點
'AGE = Round((AGE / 12), 2) '10進位的小數點
End If
End Function

複製代碼

作者: afu9240 時間: 2018-1-3 16:51

回復 10# GBKEE

G大真的是我的偶像,,感謝[attach]28199[/attach]
　G大　小妹還有一個小問題,附件用您給我的funtion為何帶不出全廠平均年齡～～～

作者: GBKEE 時間: 2018-1-3 18:32

回復 11# afu9240

'** Val(文字) > 轉換數字******************
AGE = Val(Round(Int(AGE / 12), 0) & "." & AGE - (Round(Int(AGE / 12), 0) * 12)) ' 剩餘月份的小數點
'**10進位的小數點***平均年齡較為準確 *****************
AGE = Round((AGE / 12), 2) '10進位的小數點
'*******************************************

複製代碼

Sub 平均年齡()
Dim aa As Range
Cells(1, 8) = Now()
'Times = Cells(65536, x + 1).End(xlUp).Row
Set aa = Range("d2:d" & [d2].End(xlDown).Row) '所有加總範圍
Sheets("工作表1").Cells(9, 9) = Application.WorksheetFunction.Sum(aa) / aa.Count
End Sub

複製代碼

作者: afu9240 時間: 2018-1-4 10:11

'** Val(文字) > 轉換數字******************
AGE = Val(Round(Int(AGE / 12), 0) & "." & AGE - (Round(Int(AGE / 12), 0) * 12)) ' 剩餘月份的小數點
'**10進位的小數點***平均年齡較為準確 *****************
AGE = Round((AGE / 12), 2) '10進位的小數點
'*******************************************

複製代碼

回復 12# GBKEE

請教G大這段[attach]28201[/attach][attach]28201[/attach]放進去後,原本計算的年齡會變不正確,是哪一個地方有出現問題呢!!!再請G大協助謝謝

作者: GBKEE 時間: 2018-1-4 10:51

回復 13# afu9240
給的程式碼請多了解才會為己用

'** Val(文字) > 轉換數字****是因為funtion傳回文字 ,SUM()無法加總,而修改的
AGE = Val(Round(Int(AGE / 12), 0) & "." & AGE - (Round(Int(AGE / 12), 0) * 12)) ' 剩餘月份的小數點
'**10進位的小數點***平均年齡較為準確 *****************
AGE = Round((AGE / 12), 2) '10進位的小數點 'funtion傳回數字 ,SUM()可以加總不必修改
'******************************************

複製代碼

ˋ此程式碼有註解,請再了解看看 ,二選一使用

作者: afu9240 時間: 2018-1-4 17:07

回復 14# GBKEE

感謝G大鼓勵,我會努力,>>>>>:'(

作者: afu9240 時間: 2018-1-5 13:48

回復 14# GBKEE

G大抱歉想跟您請教

要如何查詢到資料到部門人員資料後,直接計算出部門平均年齡呢???求協助謝謝

能在工作表1黃色實線儲存格顯示嗎???[attach]28204[/attach][attach]28204[/attach]

作者: GBKEE 時間: 2018-1-6 07:18

本帖最後由 GBKEE 於 2018-1-6 08:02 編輯

回復 16# afu9240

Function AGE(D1 As Date) 'Module1(一般模組)
Application.Volatile (False)
If IsDate(D1) And D1 > 0 Then
AGE = DateDiff("m", D1, Date)
'AGE = Round(Int(AGE / 12), 0) & "." & AGE - (Round(Int(AGE / 12), 0) * 12) ' 小數點為剩餘月份
'***此AGE的程式碼中** & "." & ** 傳回文字不能計算,用VAL()函數將文字轉為數字,可計算
AGE = Val(Round(Int(AGE / 12), 0) & "." & AGE - (Round(Int(AGE / 12), 0) * 12)) ' 小數點為剩餘月份
'AGE = Round((AGE / 12), 2) '小數點為10進位 '***此AGE傳回數字,可計算
End If
End Function

複製代碼

Private Sub CommandButton1_Click()
With Worksheets("人員年資分析表")
If .AutoFilterMode Then .UsedRange.AutoFilter
End With
End
End Sub
'Private Sub CommandButton4_Click() '*****
Private Sub ComboBox4_Change() '可改用Change不須再按查詢
Dim Rng As Range, AGE_Average As Double
'If ComboBox4.ListIndex = -1 Then MsgBox "請輸入正確的值": Exit Sub
If ComboBox4.ListIndex = -1 Then Exit Sub '.ListIndex = -1 不在清單的內容
Set Rng = Worksheets("人員年資分析表").Range("A2")
If Rng.Parent.AutoFilterMode Then Rng.AutoFilter '取消自動篩選
Set Rng = Range(Rng, Rng.End(xlToRight).End(xlDown))
Rng.AutoFilter 1, ComboBox4.Value
Set Rng = Range(Rng.Cells(2, 1), Rng.End(xlToRight).End(xlDown)).SpecialCells(xlCellTypeVisible)
AGE_Average = Round(Application.WorksheetFunction.Average(Rng.Columns("G")), 2)
MsgBox ComboBox4 & " 部門" & vbLf & "平均年齡 " & AGE_Average
With Worksheets("工作表1")
.Cells.Clear
Rng.Copy .[a1]
With .Range("g1", .Range("g1").End(xlDown).Address)
.Cells(.Count + 1) = "=Average(" & .Cells.Address & ")"
.Cells(.Count + 1).NumberFormatLocal = "0.00_)"
End With
End With
End Sub

複製代碼

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