thêm ứng dụng cho userform (1 người xem)

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
C

cachabu

Thành viên hoạt động
Tham gia
27/4/14
Bài viết
122
Được thích
2
chào các anh chị GPE
để tài userform em thấy cũng nhiều, nhưng em xin được tạo 1 đề tài mới luôn mong các anh chị GPE giúp

hiện tại file userform này đã tra cứu dữ liệu từ 1 file khác hoạt động ok
nhưng giờ em muốn thêm 1 nút sau khi xem xong ID đó thì muốn lưu riêng các dữ liệu đó vào 1 sheet khác trên file ADO luôn
thêm 1 nút add nêu muốn add thêm thông tin của ID mới
thêm 1 nút chỉnh sửa trường hợp muốn chỉnh sửa thông tin của ID
thêm nút hiển thị thông tin trước và sau của ID đó

file này em lấy từ diễn đàn excel luôn nhưng lại ko nhớ là từ đâu nên mới post luôn topic mới, vui lòng giúp đỡ
cám ơn
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn tham khảo code sau, một số chỗ cần bắt lỗi cho triệt để thì bạn làm nhé
Mã: 
Private Sub AddNew_click()
    On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
    Dim strPath As String
    strPath = ThisWorkbook.Path
    Dim s
    lsSQL = "INSERT INTO [Dulieu$A1:G65536]([ID],[Order],[Item Name],[Spec 1],[Color],[qty],[Unit]) IN '" & strPath & "\Database.xls" & _
            "' 'Excel 8.0;' VALUES ('" & cboID & "','" & txtOrder & "','" & txtMat & "','" & txtSpec & "','" & txtColor & "'," & txtQty & ",'" & txtUnit & "')"
    lrs.Open lsSQL, cnn, 1, 3
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub
Private Sub Update_click()
On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
       lsSQL = "Update [Dulieu$] Set" & _
            " [Order] = '" & txtOrder & _
            " ',[Item Name] ='" & txtMat & _
            " ',[Spec 1] = '" & txtSpec & _
            " ',[Color] = '" & txtColor & _
            " ',[qty] = " & txtQty & _
            " ,[Unit] = '" & txtUnit & _
            "' Where [id] = '" & CStr(Me.cboID) & "'"
            MsgBox lsSQL
            
       lrs.Open lsSQL, cnn, 1, 3
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub




Private Sub MoveNext_Click()
    On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
    cboID = Format(Me.cboID.Value + 1, "0000")
    lsSQL = "SELECT * FROM [Dulieu$] " & _
            "Where [id] ='" & cboID & _
            "' order by id"
    lrs.Open lsSQL, cnn, 1, 3
    If lrs.EOF Then
        MsgBox "Khong tim thay du lieu lien quan den ma: " & cboID & vbNewLine & "Vui long kiem tra lai.", vbCritical
        XoaTrong
    Else
        With lrs
            txtOrder = ![Order]
            txtMat = ![Item Name]
            txtSpec = IIf(IsNull(![Spec 1]), "", ![Spec 1])
            txtColor = ![Color]
            txtQty = ![qty]
            txtUnit = ![Unit]


        End With
    End If
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub


Private Sub MovePre_Click()
    On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
    cboID = Format(Me.cboID.Value - 1, "0000")
    lsSQL = "SELECT * FROM [Dulieu$] " & _
            "Where [id] ='" & cboID & _
            "' order by id"
    lrs.Open lsSQL, cnn, 1, 3
    If lrs.EOF Then
        MsgBox "Khong tim thay du lieu lien quan den ma: " & cboID & vbNewLine & "Vui long kiem tra lai.", vbCritical
        XoaTrong
    Else
        With lrs
            txtOrder = ![Order]
            txtMat = ![Item Name]
            txtSpec = IIf(IsNull(![Spec 1]), "", ![Spec 1])
            txtColor = ![Color]
            txtQty = ![qty]
            txtUnit = ![Unit]


        End With
    End If
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub
 
Upvote 0
dhn46 đã viết:
Bạn tham khảo code sau, một số chỗ cần bắt lỗi cho triệt để thì bạn làm nhé
Nhấp chuột vào đây để mở rộng...
dạ em xin cám ơn anh nhiều lắm, nhưng code dài quá, em lại gà về vba và ado nên phải có thời gian xem lại đoạn code của anh,
cám ơn
 
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote 0
code dùng chưa được anh ơi
 
Lần chỉnh sửa cuối:
Upvote 0
dhn46 đã viết:
Bạn tham khảo code sau, một số chỗ cần bắt lỗi cho triệt để thì bạn làm nhé
Mã: 
Private Sub AddNew_click()
    On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
    Dim strPath As String
    strPath = ThisWorkbook.Path
    Dim s
    lsSQL = "INSERT INTO [Dulieu$A1:G65536]([ID],[Order],[Item Name],[Spec 1],[Color],[qty],[Unit]) IN '" & strPath & "\Database.xls" & _
            "' 'Excel 8.0;' VALUES ('" & cboID & "','" & txtOrder & "','" & txtMat & "','" & txtSpec & "','" & txtColor & "'," & txtQty & ",'" & txtUnit & "')"
    lrs.Open lsSQL, cnn, 1, 3
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub
Private Sub Update_click()
On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
       lsSQL = "Update [Dulieu$] Set" & _
            " [Order] = '" & txtOrder & _
            " ',[Item Name] ='" & txtMat & _
            " ',[Spec 1] = '" & txtSpec & _
            " ',[Color] = '" & txtColor & _
            " ',[qty] = " & txtQty & _
            " ,[Unit] = '" & txtUnit & _
            "' Where [id] = '" & CStr(Me.cboID) & "'"
            MsgBox lsSQL
            
       lrs.Open lsSQL, cnn, 1, 3
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub




Private Sub MoveNext_Click()
    On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
    cboID = Format(Me.cboID.Value + 1, "0000")
    lsSQL = "SELECT * FROM [Dulieu$] " & _
            "Where [id] ='" & cboID & _
            "' order by id"
    lrs.Open lsSQL, cnn, 1, 3
    If lrs.EOF Then
        MsgBox "Khong tim thay du lieu lien quan den ma: " & cboID & vbNewLine & "Vui long kiem tra lai.", vbCritical
        XoaTrong
    Else
        With lrs
            txtOrder = ![Order]
            txtMat = ![Item Name]
            txtSpec = IIf(IsNull(![Spec 1]), "", ![Spec 1])
            txtColor = ![Color]
            txtQty = ![qty]
            txtUnit = ![Unit]


        End With
    End If
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub


Private Sub MovePre_Click()
    On Error GoTo ErrHandle
    Dim lsSQL As String
    Dim lrs As New ADODB.Recordset
    cboID = Format(Me.cboID.Value - 1, "0000")
    lsSQL = "SELECT * FROM [Dulieu$] " & _
            "Where [id] ='" & cboID & _
            "' order by id"
    lrs.Open lsSQL, cnn, 1, 3
    If lrs.EOF Then
        MsgBox "Khong tim thay du lieu lien quan den ma: " & cboID & vbNewLine & "Vui long kiem tra lai.", vbCritical
        XoaTrong
    Else
        With lrs
            txtOrder = ![Order]
            txtMat = ![Item Name]
            txtSpec = IIf(IsNull(![Spec 1]), "", ![Spec 1])
            txtColor = ![Color]
            txtQty = ![qty]
            txtUnit = ![Unit]


        End With
    End If
    Set lrs = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description
End Sub
Nhấp chuột vào đây để mở rộng...
xin cám ơn anh
hiện code này e copy vào rồi nhưng có 1 số vấn đề như sau nhờ a giúp đỡ
1. nút addnew hoạt động ok tuy nhiên em muốn khi addnew những dữ liệu trùng thì sẻ hiện thông báo không cho add thêm nữa.
2. nút next và back là để xem những ID vừa tra cứu trước và sau bị lỗi không hoạt động được.
3. nút "lưu thông tin đã tra cứu và sheet 2" của file ADO thì chưa có code.
4. em muốn tạo thêm 1 nút tra cứu theo cột ODER nữa có được không? có nghĩa là nếu biết số ID thì sẻ nhập số ID còn nếu biết số oder thì sẽ nhập vào combobox oder(tra cứu theo oder thì lúc này ID sẽ hiển thị ở textbox).

cám ơn
 

File đính kèm

Upvote 0
cachabu đã viết:
xin cám ơn anh
hiện code này e copy vào rồi nhưng có 1 số vấn đề như sau nhờ a giúp đỡ
1. nút addnew hoạt động ok tuy nhiên em muốn khi addnew những dữ liệu trùng thì sẻ hiện thông báo không cho add thêm nữa.
2. nút next và back là để xem những ID vừa tra cứu trước và sau bị lỗi không hoạt động được.
3. nút "lưu thông tin đã tra cứu và sheet 2" của file ADO thì chưa có code.
4. em muốn tạo thêm 1 nút tra cứu theo cột ODER nữa có được không? có nghĩa là nếu biết số ID thì sẻ nhập số ID còn nếu biết số oder thì sẽ nhập vào combobox oder(tra cứu theo oder thì lúc này ID sẽ hiển thị ở textbox).

cám ơn
Nhấp chuột vào đây để mở rộng...
Chào bạn,

1/ Trùng là như thế nào bạn? Nếu là trùng ID thì bạn có thể dùng ADO để kiểm tra xem số record mà tồn tại thì update

2/ Nút Next, Back bạn kiểm tra lại copy past có lỗi gì không chứ tôi thấy thừa dòng khai báo tại file của bạn
Mã: 
dim format

3/ Nút lưu thông tin tại sheet 2 file ADO, lưu như thế nào? Lưu vào dòng nào, cột nào bạn cũng nên cho một chút format, chí ít cũng là định dạng cái sheet 2 nhỉ?

Cái này bạn có thể làm mà, theo dạng
Mã: 
[A1] = cboID
...

4/ Nút tra cứu theo Order thì bạn dùng tất cả code phần tra theo ID và sửa là truy vấn như sau
Mã: 
       lsSQL = "SELECT * FROM [Dulieu$] " & _
                "Where [ORDER] like '" & IIf(Len(CboOrder.Text) = 0, "%", cboID.Text) & _
                "' order by id"
 
Upvote 0
dhn46 đã viết:
Chào bạn,

1/ Trùng là như thế nào bạn? Nếu là trùng ID thì bạn có thể dùng ADO để kiểm tra xem số record mà tồn tại thì update

2/ Nút Next, Back bạn kiểm tra lại copy past có lỗi gì không chứ tôi thấy thừa dòng khai báo tại file của bạn
Mã: 
dim format

3/ Nút lưu thông tin tại sheet 2 file ADO, lưu như thế nào? Lưu vào dòng nào, cột nào bạn cũng nên cho một chút format, chí ít cũng là định dạng cái sheet 2 nhỉ?

Cái này bạn có thể làm mà, theo dạng
Mã: 
[A1] = cboID
...

4/ Nút tra cứu theo Order thì bạn dùng tất cả code phần tra theo ID và sửa là truy vấn như sau
Mã: 
       lsSQL = "SELECT * FROM [Dulieu$] " & _
                "Where [ORDER] like '" & IIf(Len(CboOrder.Text) = 0, "%", cboID.Text) & _
                "' order by id"
Nhấp chuột vào đây để mở rộng...
cái khai báo dim format là mình bỏ vào thử thế nào bạn thử xóa đi thì nó vẫn báo lỗi như sau: can't find project or library"
còn cái bạn nói lưu sheet2 thì bạn cư cho vào từ cột A2 cũng được mục đích là chỉ muốn những cái mình vừa truy vấn xong và muốn lưu vào sheet 2 để biết được mình đã truy vấn những ID đó. thực ra nó giống như nút addnew nhưng thay vì lưu vào file database thì nó lưu vào sheet2(hiển thị giống như file database)
bạn ơi có thể làm vào file excel luôn được không như vậy mình dễ hiểu hơn.
cám ơn
 
Lần chỉnh sửa cuối:
Upvote 0
Chào bạn,

Với lỗi can't find project or library" là do bạn khai báo dạng
Mã: 
Dim Lrs As New ADODB.Recordset
......
trong file bạn có khai báo như thế cho Lrs và cnn, bới nó sẽ tham chiếu đến thư viện đã được load sẵn trong VBE, nếu chưa load sẽ gây lỗi.

Để khắc phục bạn làm như sau:

- Bước 1: bạn thay toàn bộ Code trong Module khai báo của bạn như sau
Mã: 
Public Cnn As Object
Public Lrs As Object
Sub Moketnoi()
    Dim i, r As Integer: Dim strPath As String
    Set Cnn = CreateObject("ADODB.Connection")
    Set Lrs = CreateObject("ADODB.recordset")
    strPath = ThisWorkbook.Path  'Thay doi duong dan den file chua du lieu cua ban vi du "\\May1\DulieuChiaSe"
    With Cnn
        .ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0; data source=" & strPath & _
                            "\Database.xls;Extended Properties=Excel 8.0;"
        .CursorLocation = adUseClient
        .Open
    End With
loi:
End Sub

- Bước 2: Bạn xóa toàn bộ dòng Code có dạng
Mã: 
Dim Lrs As New ADODB.Recordset

Các câu hỏi còn lại bạn tự tìm hiểu nhé, Voọc 1 chút cũng hay phải không bạn ^^?
 
Upvote 0
dhn46 đã viết:
Chào bạn,

Với lỗi can't find project or library" là do bạn khai báo dạng
Mã: 
Dim Lrs As New ADODB.Recordset
......
trong file bạn có khai báo như thế cho Lrs và cnn, bới nó sẽ tham chiếu đến thư viện đã được load sẵn trong VBE, nếu chưa load sẽ gây lỗi.

Để khắc phục bạn làm như sau:

- Bước 1: bạn thay toàn bộ Code trong Module khai báo của bạn như sau
Mã: 
Public Cnn As Object
Public Lrs As Object
Sub Moketnoi()
    Dim i, r As Integer: Dim strPath As String
    Set Cnn = CreateObject("ADODB.Connection")
    Set Lrs = CreateObject("ADODB.recordset")
    strPath = ThisWorkbook.Path  'Thay doi duong dan den file chua du lieu cua ban vi du "\\May1\DulieuChiaSe"
    With Cnn
        .ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0; data source=" & strPath & _
                            "\Database.xls;Extended Properties=Excel 8.0;"
        .CursorLocation = adUseClient
        .Open
    End With
loi:
End Sub

- Bước 2: Bạn xóa toàn bộ dòng Code có dạng
Mã: 
Dim Lrs As New ADODB.Recordset

Các câu hỏi còn lại bạn tự tìm hiểu nhé, Voọc 1 chút cũng hay phải không bạn ^^?
Nhấp chuột vào đây để mở rộng...
làm như bạn nói luôn đó, mà vẫn lỗi nhờ bạn xem lại giúp sửa thế nào nhé. mình gà mấy cái này lắm, có gì nhờ bạn giúp

cám ơn
 

File đính kèm

Upvote 0
Bạn tham khảo file nhé
 

File đính kèm

Upvote 0
Xem lại thì thấy còn 1 yêu cầu của bạn về kiểm tra sự tồn tại của ID khi Addnew, bạn tham khảo code kiểm tra sự tồn tại của ID rồi áp dụng nhé
Mã: 
Sub Check()
    Dim lsSQL As String
    Set Lrs = CreateObject("ADODB.recordset")
    lsSQL = "SELECT * FROM [Dulieu$] " & _
            "Where [id] like '" & cboID.Text & "'"
    Lrs.Open lsSQL, Cnn, 1, 3
    If Lrs.RecordCount Then
        MsgBox "Da co ID nay roi, Khong duoc tao moi nua"
    End If
    Set Lrs = Nothing
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

L
Tính thời gian làm việc thực tế
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
630
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI (2 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
6
Đọc
409
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho (1 người xem)
Trả lời
4
Đọc
110
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật
Trả lời
1
Đọc
58
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi
Trả lời
5
Đọc
109
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
218
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
159
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
315
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
287
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (2 người xem)
    • Thích
Trả lời
0
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
135
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
371
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
702
nghiabros
N
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom