因為作業原因，經常要用好幾個表格保存資料，每次用到都要找不同的表格，很麻煩，想做個小程式，實作輸入某個字符，查詢相應的資訊顯示出來，如果原表格查不到，就自己手動添加到原來的表格（可以添加到最后一行現有資料的下一行）并保存；
剛剛接觸到VB只有短短的幾天，只是有這樣的想法，但不知道如何實作，也不知道問題描述的是否清晰，自己做了小程式的大概布局，也做了一個標的的模板，截圖發上來，希望老師能幫忙看看，也想學學具體的程式流程怎么寫
--------------------------------------------------------------------------------------------------------------------------------------------------
【小 程 序 布 局】
uj5u.com熱心網友回復：
寫好了,不知道是否滿足你的要求,代碼如下:
Option Explicit
Private Sub cmd查詢_Click()
txt查詢定損地點.Text = ""
txt查詢賬號后六位.Text = ""
txt查詢開戶行縮寫.Text = ""
Dim excel As Object
Set excel = CreateObject("excel.application")
excel.Visible = True
Dim wb As Object
Set wb = excel.workbooks.open(App.Path & "\Book1.xlsx")
Dim ws As Object
Set ws = wb.sheets(1)
Dim blnFound As Boolean
blnFound = False
Dim i As Long
i = 3
Do While ws.cells(i, "A") <> ""
If InStr(1, ws.cells(i, "A"), txt定損地點關鍵字.Text, vbTextCompare) > 0 Then
txt查詢定損地點.Text = ws.cells(i, "A").Value
txt查詢賬號后六位.Text = ws.cells(i, "B").Value
txt查詢開戶行縮寫.Text = ws.cells(i, "C").Value
blnFound = True
Exit Do
End If
Loop
wb.Close
excel.quit
If Not blnFound Then
MsgBox "未找到匹配資訊!", vbExclamation
End If
End Sub
Private Sub cmd添加_Click()
Const xlDown As Long = -4121
Dim excel As Object
Set excel = CreateObject("excel.application")
excel.Visible = True
Dim wb As Object
Set wb = excel.workbooks.open(App.Path & "\Book1.xlsx")
Dim ws As Object
Set ws = wb.sheets(1)
Dim row As Long
row = ws.UsedRange.End(xlDown).row + 1
ws.cells(row, "A").Value = txt添加定損地點.Text
ws.cells(row, "B").formula = "=RIGHT(SUBSTITUTE(D" & row & ","" "",""""),6)"
ws.cells(row, "C").formula = "=LEFT(E" & row & ",2)"
ws.cells(row, "D").Value = txt添加賬號.Text
ws.cells(row, "E").Value = txt添加開戶行.Text
wb.save
wb.Close
excel.quit
txt添加定損地點.Text = ""
txt添加賬號.Text = ""
txt添加開戶行.Text = ""
End Sub
下載地址:
鏈接：https://pan.baidu.com/s/1LUtbLZMzoG4iEZjkSV3r1A
提取碼：v8je
運行示例:
uj5u.com熱心網友回復：
謝謝老師的指導，正在看老師的代碼學習，有幾段代碼不是很理解，回頭把代碼復制到軟體里加上注釋再發上來，在麻煩老師幫忙看看我的理解對不對
uj5u.com熱心網友回復：
代碼有點問題,i忘記加1了,等我改改;uj5u.com熱心網友回復：
改好了,代碼如下:
Option Explicit
Private Sub cmd查詢_Click()
txt查詢定損地點.Text = ""
txt查詢賬號后六位.Text = ""
txt查詢開戶行縮寫.Text = ""
Dim excel As Object
Set excel = CreateObject("excel.application")
excel.Visible = True
Dim wb As Object
Set wb = excel.workbooks.open(App.Path & "\Book1.xlsx")
Dim ws As Object
Set ws = wb.sheets(1)
Dim blnFound As Boolean
blnFound = False
Dim i As Long
i = 3
Do While ws.cells(i, "A") <> ""
If InStr(1, ws.cells(i, "A"), txt定損地點關鍵字.Text, vbTextCompare) > 0 Then
txt查詢定損地點.Text = ws.cells(i, "A").Value
txt查詢賬號后六位.Text = ws.cells(i, "B").Value
txt查詢開戶行縮寫.Text = ws.cells(i, "C").Value
blnFound = True
Exit Do
End If
i = i + 1
Loop
wb.Close
excel.quit
If Not blnFound Then
MsgBox "未找到匹配資訊!", vbExclamation
End If
End Sub
Private Sub cmd添加_Click()
Const xlDown As Long = -4121
Dim excel As Object
Set excel = CreateObject("excel.application")
excel.Visible = True
Dim wb As Object
Set wb = excel.workbooks.open(App.Path & "\Book1.xlsx")
Dim ws As Object
Set ws = wb.sheets(1)
Dim row As Long
row = ws.UsedRange.End(xlDown).row + 1
ws.cells(row, "A").Value = txt添加定損地點.Text
ws.cells(row, "B").formula = "=RIGHT(SUBSTITUTE(D" & row & ","" "",""""),6)"
ws.cells(row, "C").formula = "=LEFT(E" & row & ",2)"
ws.cells(row, "D").Value = txt添加賬號.Text
ws.cells(row, "E").Value = txt添加開戶行.Text
wb.save
wb.Close
excel.quit
txt添加定損地點.Text = ""
txt添加賬號.Text = ""
txt添加開戶行.Text = ""
End Sub
下載地址:
鏈接：https://pan.baidu.com/s/19y8rt-yzIbH2PAHigi9UJQ
提取碼：2c7l
uj5u.com熱心網友回復：
幫著看看這個？
https://bbs.csdn.net/topics/395549161
uj5u.com熱心網友回復：
row = ws.UsedRange.End(xlDown).row + 1改成
row = ws.usedrange.rows.Count + 1
uj5u.com熱心網友回復：
因為作業原因，經常要用好幾個表格保存資料，每次用到都要找不同的表格，很麻煩，想做個小程式，實作輸入某個字符，查詢相應的資訊顯示出來-----------------------------------------------
那你不是經常需要切換表格么
uj5u.com熱心網友回復：
對的，目前樓上的老師做的小程式修改過后已經能實作了賬號查詢，添加的功能，其他的，估計也只能用表格處理，要篩選，透視，沒有辦法
uj5u.com熱心網友回復：
老師，請教一下，這兩句話分別都是什么意思，我百度也沒弄明白個所以然
uj5u.com熱心網友回復：
意思是找到excel中ws表格的有效行數,然后再加1;uj5u.com熱心網友回復：
兩句都是獲取這個Sheet表中已被使用的行數，后面一句比前一句效率高uj5u.com熱心網友回復：
我幫你做了一個 能夠同時對若干excel進行查找 且查找途中不需要幕后打開excel 如果你每個excel資料行數不超過幾千行的話應該是很流暢的，不過我沒有百度云。。。。
uj5u.com熱心網友回復：
樓上發的不能多選 每次查詢都需要幕后打開一次excel 而且既然都已經幕后打開了還用回圈找就有點笨了uj5u.com熱心網友回復：
老師，您的帖子沒有跟檔案和原始碼，我現在的水平也只是比葫蘆畫瓢，讓我自己寫還真寫不出來，但是您的界面看起來很好看，很想跟您學學
uj5u.com熱心網友回復：
老師，謝謝你的指導，你的代碼我看著大概能看懂了點，細節的“比如用的什么函式”“屬性的用法”“變數”等等還都不懂，比這你的代碼我修改了一下界面和內容又折騰出了一個小程式，麻煩您給看看點評一下“PS：屬于純抄襲，還請不要見怪！”
Option Explicit
Private Sub Form_Load()
Label1.Caption = "大 案 登 記"
Label1.ForeColor = vbRed '改變字體顏色為紅色
Label1.FontSize = 20 '設定字號為20
Label1.FontBold = True '設定字體加粗
Label1.AutoSize = True '設定隨內容改變控制元件大小
Label1.Alignment = 2
'文本框初始化
txt報案號.Text = "RDAA2020410300N000"
txt車輛型號.Text = ""
txt車牌號.Text = "豫C"
txt查勘員.Text = ""
txt查勘人電話.Text = ""
txt首推店面.Text = ""
txt二次送修店面.Text = ""
txt推送時間.Text = ""
txt事故型別.Text = ""
txt估損金額.Text = ""
txt備注.Text = ""
txt跟蹤責任人.Text = ""
txt跟蹤.Text = ""
txt事故經過.Text = ""
End Sub
Private Sub 查詢_Click()
Dim excel As Object
Set excel = CreateObject("excel.application")
excel.Visible = True
Dim wb As Object
Set wb = excel.workbooks.open(App.Path & "\大案登記.xlsx")
Dim ws As Object
Set ws = wb.sheets(1)
Dim blnFound As Boolean
blnFound = False
Dim i As Long
i = 2
Do While ws.cells(i, "A") <> ""
If InStr(1, ws.cells(i, "A"), txt報案號.Text, vbTextCompare) > 0 Then
txt車輛型號.Text = ws.cells(i, "A").Value
txt車牌號.Text = ws.cells(i, "C").Value
txt查勘員.Text = ws.cells(i, "D").Value
txt查勘人電話.Text = ws.cells(i, "E").Value
txt首推店面.Text = ws.cells(i, "F").Value
txt二次送修店面.Text = ws.cells(i, "G").Value
txt事故經過.Text = ws.cells(i, "H").Value
txt推送時間.Text = ws.cells(i, "I").Value
txt事故型別.Text = ws.cells(i, "J").Value
txt估損金額.Text = ws.cells(i, "K").Value
txt跟蹤責任人.Text = ws.cells(i, "L").Value
txt備注.Text = ws.cells(i, "M").Value
txt跟蹤.Text = ws.cells(i, "N").Value
blnFound = True
Exit Do
End If
i = i + 1
Loop
wb.Close
excel.quit
If Not blnFound Then
MsgBox "未找到匹配資訊!", vbExclamation
End If
End Sub
Private Sub 添加_Click()
Const xlDown As Long = -4121
Dim excel As Object
Set excel = CreateObject("excel.application")
excel.Visible = False
Dim wb As Object
Set wb = excel.workbooks.open(App.Path & "\大案登記.xlsx")
Dim ws As Object
Set ws = wb.sheets(1)
Dim row As Long
row = ws.usedRange.rows.Count + 1
ws.cells(row, "A").Value = txt車輛型號.Text
ws.cells(row, "B").Value = txt報案號.Text
ws.cells(row, "C").formula = txt車牌號.Text
ws.cells(row, "D").Value = txt查勘員.Text
ws.cells(row, "E").Value = txt查勘人電話.Text
ws.cells(row, "F").Value = txt首推店面.Text
ws.cells(row, "G").Value = txt二次送修店面.Text
ws.cells(row, "H").Value = txt事故經過.Text
ws.cells(row, "I").Value = txt推送時間.Text
ws.cells(row, "J").Value = txt事故型別.Text
ws.cells(row, "K").Value = txt估損金額.Text
ws.cells(row, "L").Value = txt跟蹤責任人.Text
ws.cells(row, "M").Value = txt備注.Text
ws.cells(row, "N").Value = txt跟蹤.Text
wb.save
wb.Close
excel.quit
MsgBox "資訊已添加!", vbExclamation
'文本框初始化
txt報案號.Text = "RDAA2020410300N000"
txt車輛型號.Text = ""
txt車牌號.Text = "豫C"
txt查勘員.Text = ""
txt查勘人電話.Text = ""
txt首推店面.Text = ""
txt二次送修店面.Text = ""
txt推送時間.Text = ""
txt事故型別.Text = ""
txt估損金額.Text = ""
txt備注.Text = ""
txt跟蹤責任人.Text = ""
txt跟蹤.Text = ""
txt事故經過.Text = ""
End Sub
uj5u.com熱心網友回復：
挺好;
uj5u.com熱心網友回復：
Dim ctr, Rn As Long
Dim oe, ob As Object
Dim fn, fns, sh As String
Private Sub Form_Load()
Set oe = CreateObject("Excel.application")
oe.DisplayAlerts = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set oe = Nothing
End Sub
Private Sub 已選_Change()
Set ob = oe.workbooks.Open(已選)
sh = ob.Sheets(1).Name
Rn = oe.application.counta(ob.Sheets(1).Columns(1))
ob.Close
Set ob = Nothing
If Len(已選) > 0 Then
搜索框.Enabled = True
添加按鍵.Enabled = True
Else
搜索框.Enabled = False
添加按鍵.Enabled = False
End If
Call 查找
End Sub
Private Sub 拖入框_Click()
已選 = 拖入框
i = InStrRev(拖入框, "\")
fn = Mid(拖入框, i + 1, Len(拖入框) - i)
fns = Left(拖入框, i)
End Sub
Private Sub 拖入框_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To Data.Files.Count
拖入框.AddItem Data.Files(i)
Next
End Sub
Private Sub 搜索框_Change()
If Len(搜索框) = 0 Then
定損地點框 = ""
賬號后六位 = ""
開戶行縮寫 = ""
End If
End Sub
Sub 查找()
On Error Resume Next
If Len(已選) > 0 And Len(搜索框) > 0 Then
定損地點框 = ""
賬號后六位 = ""
開戶行縮寫 = ""
For ctr = 1 To Rn
ed = oe.ExecuteExcel4Macro("'" & fns & "[" & fn & "]" & sh & "'!R" & ctr & "C1")
If InStr(ed, 搜索框) > 0 Then
定損地點框 = ed
賬號后六位 = oe.ExecuteExcel4Macro("'" & fns & "[" & fn & "]" & sh & "'!R" & ctr & "C" & 2)
開戶行縮寫 = oe.ExecuteExcel4Macro("'" & fns & "[" & fn & "]" & sh & "'!R" & ctr & "C" & 3)
Exit Sub
End If
Next ctr
MsgBox "找不到目標", vbInformation
End If
End Sub
Private Sub 添加按鍵_Click()
On Error Resume Next
If Len(已選) > 0 And Len(定損地點添加) > 0 And Len(開戶行) > 0 And Len(賬號) > 0 Then
Set ob = oe.workbooks.Open(已選)
Rctr = oe.application.counta(ob.Sheets(1).Columns(1)) + 1
ob.Sheets(1).cells(Rctr, 1) = 定損地點添加
ob.Sheets(1).cells(Rctr, 4) = 開戶行
ob.Sheets(1).cells(Rctr, 5) = 賬號
ob.Sheets(1).cells(Rctr - 1, 2).Resize(2, 2).filldown
Rn = Rn + 1
ob.save
ob.Close
Set ob = Nothing
MsgBox "添加完成"
定損地點添加 = ""
開戶行 = ""
賬號 = ""
Else
MsgBox "請先填寫完資訊", vbCritical
End If
End Sub
Private Sub 搜索按鍵_Click()
Call 查找
End Sub
Private Sub 搜索框_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then Call 查找
End Sub
uj5u.com熱心網友回復：
這個小程式的優點是能隨時切換需要查詢和保存的Excel檔案 在查詢程序中完全不打開Excel檔案 只有切換和添加的時候瞬間打開一次 缺點是資料量太龐大會卡 大概幾千行 我剛知道這個網站 好像發不了檔案uj5u.com熱心網友回復：
用百度網盤發,或者在這里https://download.csdn.net/發,不過要審核;
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/18501.html
標籤：VB基礎類