Khai thác và tùy biến thêm, sửa, xuất file và lấy dữ liệu từ Recordset

Liên hệ QC
Lấy file mẫu bài số 1, tạo thêm cột 'Running Total' theo code sau:

Rich (BB code): 
Sub Page_HLMT_5()
    Dim intPage As Integer, i As Integer, intSq As Integer, intRecord As Integer
    Dim lngTotal As Long, lngRunningTotal As Long
    With CreateObject("ADODB.Recordset")
        .Open "Select * from [Sheet1$]", "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName, 1
        .PageSize = 20
        Sheet2.Cells.ClearContents
        For intPage = 1 To .PageCount
            lngTotal = 0
            For intRecord = 1 To .PageSize
                i = i + 1
                intSq = intSq + 1
                Sheet2.Range("A" & i) = intSq
                Sheet2.Range("B" & i) = !ID & " >> " & !Code
                Sheet2.Range("C" & i) = !Code
                Sheet2.Range("D" & i) = Format(!Price, "0,#")
                lngRunningTotal = !Price + lngRunningTotal
                Sheet2.Range("E" & i) = Format(lngRunningTotal, "0,#")
                lngTotal = lngTotal + !Price
                .MoveNext
                If .EOF Then Exit For
            Next
            i = i + 1
            Sheet2.Range("C" & i) = "Total:"
            Sheet2.Range("D" & i) = Format(lngTotal, "0,#")
        Next
    End With
End Sub

Kết quả sẽ như hình sau:

1605320577204.png
 
Hai Lúa Miền Tây đã viết:
Lấy file mẫu bài số 1, tạo thêm cột 'Running Total' theo code sau:

Rich (BB code): 
Sub Page_HLMT_5()
    Dim intPage As Integer, i As Integer, intSq As Integer, intRecord As Integer
    Dim lngTotal As Long, lngRunningTotal As Long
    With CreateObject("ADODB.Recordset")
        .Open "Select * from [Sheet1$]", "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName, 1
        .PageSize = 20
        Sheet2.Cells.ClearContents
        For intPage = 1 To .PageCount
            lngTotal = 0
            For intRecord = 1 To .PageSize
                i = i + 1
                intSq = intSq + 1
                Sheet2.Range("A" & i) = intSq
                Sheet2.Range("B" & i) = !ID & " >> " & !Code
                Sheet2.Range("C" & i) = !Code
                Sheet2.Range("D" & i) = Format(!Price, "0,#")
                lngRunningTotal = !Price + lngRunningTotal
                Sheet2.Range("E" & i) = Format(lngRunningTotal, "0,#")
                lngTotal = lngTotal + !Price
                .MoveNext
                If .EOF Then Exit For
            Next
            i = i + 1
            Sheet2.Range("C" & i) = "Total:"
            Sheet2.Range("D" & i) = Format(lngTotal, "0,#")
        Next
    End With
End Sub

Kết quả sẽ như hình sau:

View attachment 249314
Nhấp chuột vào đây để mở rộng...
Ahii, cột lũy kế hay quá anh Hai à.
Giả sử gọi cột D trong hình này là đơn giá và thêm cột số lượng vào bảng dữ liệu nguồn thì code sẽ viết thế nào để ra bảng dữ liệu kế quả gồm đầy đủ các cột đơn giá, số lượng và thêm cột thành tiền nữa vậy anh ơi?
 
NHN_Phương đã viết:
Ahii, cột lũy kế hay quá anh Hai à.
Giả sử gọi cột D trong hình này là đơn giá và thêm cột số lượng vào bảng dữ liệu nguồn thì code sẽ viết thế nào để ra bảng dữ liệu kế quả gồm đầy đủ các cột đơn giá, số lượng và thêm cột thành tiền nữa vậy anh ơi?
Nhấp chuột vào đây để mở rộng...
Thì em thêm vào rồi lấy 2 cột đó nhân nhau là ra được kết quả thôi mà em. Thử làm đi, vướng chỗ nào lên đây hỏi nhé.
 
MinhKhai đã viết:
Tiện đây cũng xin hỏi bạn dùng phương pháp nào vậy? Có dùng kỹ thuật ADO hay cách khác ?
Nhấp chuột vào đây để mở rộng...

Dùng ADO Recordset với phương thức .DataSource như bác HLMT đã giới thiệu.
Code bên dưới chạy như hình gif trong bài post trước của tôi chứ chưa code chạy vòng lập vô tận nhé.
Chú ý là dùng Cursor Type = adOpenDynaset để khi có cập nhật thay đổi danh sách từ máy khác thì nó cũng cập nhật vô Recordset đang chạy luôn. (Tôi không có máy khác để thử)

Hai Lúa Miền Tây đã viết:
Chần chừ gì nữa chia sẻ đi bạn.
Nhấp chuột vào đây để mở rộng...

Mã: 
Dim i As Long
    With rs
        .Open ("Select * from [DS$]"), cn, adOpenDynamic, adLockOptimistic
        i = 0
        Do Until i > .RecordCount
            .MoveFirst
            .Move i
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            If i > .RecordCount - 5 Then
                Sheet2.Range("F" & 3 + (.RecordCount - i) & ":G6").ClearContents
            End If
            i = i + 1
            Application.Wait (Now + TimeValue("00:00:01"))
        Loop
    End With
    MsgBox "Het danh sach."
 
    rs.Close
    Set rs = Nothing
 

File đính kèm

Lần chỉnh sửa cuối:
ongke0711 đã viết:
Dùng ADO Recordset với phương thức .DataSource như bác HLMT đã giới thiệu.
Code bên dưới chạy như hình gif trong bài post trước của tôi chứ chưa code chạy vòng lập vô tận nhé.
Chú ý là dùng Cursor Type = adOpenDynaset để khi có cập nhật thay đổi danh sách từ máy khác thì nó cũng cập nhật vô Recordset đang chạy luôn. (Tôi không có máy khác để thử)



Mã: 
Dim i As Long
    With rs
        .Open ("Select * from [DS$]"), cn, adOpenDynamic, adLockOptimistic
        i = 0
        Do Until i > .RecordCount
            .MoveFirst
            .Move i
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            If i > .RecordCount - 5 Then
                Sheet2.Range("F" & 3 + (.RecordCount - i) & ":G6").ClearContents
            End If
            i = i + 1
            Application.Wait (Now + TimeValue("00:00:01"))
        Loop
    End With
    MsgBox "Het danh sach."

    rs.Close
    Set rs = Nothing
Nhấp chuột vào đây để mở rộng...
Cảm ơn @ongke0711 rất nhiều. Từ code của bạn mình sẽ thử áp dụng để show dữ liệu từ SQL Server. Tuy nhiên có 1 vấn đề nhỏ là khi chạy code của bạn, con trỏ chuột nó quay tít, hiện tượng này có cách nào xử lý được không nhỉ ?
 
ongke0711 đã viết:
Dùng ADO Recordset với phương thức .DataSource như bác HLMT đã giới thiệu.
Code bên dưới chạy như hình gif trong bài post trước của tôi chứ chưa code chạy vòng lập vô tận nhé.
Chú ý là dùng Cursor Type = adOpenDynaset để khi có cập nhật thay đổi danh sách từ máy khác thì nó cũng cập nhật vô Recordset đang chạy luôn. (Tôi không có máy khác để thử)



Mã: 
Dim i As Long
    With rs
        .Open ("Select * from [DS$]"), cn, adOpenDynamic, adLockOptimistic
        i = 0
        Do Until i > .RecordCount
            .MoveFirst
            .Move i
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            If i > .RecordCount - 5 Then
                Sheet2.Range("F" & 3 + (.RecordCount - i) & ":G6").ClearContents
            End If
            i = i + 1
            Application.Wait (Now + TimeValue("00:00:01"))
        Loop
    End With
    MsgBox "Het danh sach."

    rs.Close
    Set rs = Nothing
Nhấp chuột vào đây để mở rộng...
Vòng lặp vô tận đây.
Mã: 
Sub ScrollRecords()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim so As Integer
    Application.Cursor = xlIBeam
    With cn
        .CursorLocation = adUseClient
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
                            "Extended Properties=""Excel 12.0;HDR=Yes;"";"
        .Open
    End With
    Dim i As Long
    With rs
        .Open ("Select * from [DS$]"), cn, adOpenDynamic, adLockOptimistic
        i = 0
        so = .RecordCount
        For i = 0 To so + 1
            .MoveFirst
            .Move i - 1
            Sheet2.Range("F2:G10").ClearContents
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            i = i + 1
            Application.Wait (Now + TimeValue("00:00:01"))
            If i > so Then
                i = 0
                .MoveFirst
            End If
        Next
    End With
    'MsgBox "Het danh sach."
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub
@MinhKhai
Nhớ reset lại con trỏ chuột về bình thường khi nhấn Ctrl+Pause Break nhé :D
 
Hai Lúa Miền Tây đã viết:
Vòng lặp vô tận đây.
Mã: 
Sub ScrollRecords()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim so As Integer
    Application.Cursor = xlIBeam
    With cn
        .CursorLocation = adUseClient
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
                            "Extended Properties=""Excel 12.0;HDR=Yes;"";"
        .Open
    End With
    Dim i As Long
    With rs
        .Open ("Select * from [DS$]"), cn, adOpenDynamic, adLockOptimistic
        i = 0
        so = .RecordCount
        For i = 0 To so + 1
            .MoveFirst
            .Move i - 1
            Sheet2.Range("F2:G10").ClearContents
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            i = i + 1
            Application.Wait (Now + TimeValue("00:00:01"))
            If i > so Then
                i = 0
                .MoveFirst
            End If
        Next
    End With
    'MsgBox "Het danh sach."
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub
@MinhKhai
Nhớ reset lại con trỏ chuột về bình thường khi nhấn Ctrl+Pause Break nhé :D
Nhấp chuột vào đây để mở rộng...
Có thể rút gọn code trên như sau:

Mã: 
Sub ScrollRecords()
    Dim so As Integer, i As Integer
    Application.Cursor = xlIBeam
 
    With CreateObject("ADODB.Recordset")
        .Open ("Select * from [DS$]"), "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName, 1, 3
        i = 0
        so = .RecordCount
        For i = 0 To so + 1
            .MoveFirst
            .Move i - 1
            Sheet2.Range("F2:G10").ClearContents
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            i = i + 1
            Application.Wait (Now + TimeValue("00:00:01"))
            If i > so Then
                i = 0
                .MoveFirst
            End If
        Next
    End With
  
End Sub

@ongke0711 : Mình thay adOpenDynamic (2) thành adOpenKeyset (1) ở code trên mới có thể chạy được với cách này.
 
Hai Lúa Miền Tây đã viết:
Có thể rút gọn code trên như sau:

Mã: 
...
            Sheet2.Range("F2:G10").ClearContents
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            ...

@ongke0711 : Mình thay adOpenDynamic (2) thành adOpenKeyset (1) ở code trên mới có thể chạy được với cách này.
Nhấp chuột vào đây để mở rộng...

Sao trên máy tôi nếu áp dụng kiểu xoá toàn bộ Cell trước khi cập nhật (dùng code của bạn) thì nó nháy hiển thị nội dung rất nhanh, không kịp nhìn, sau đó xoá trắng cell và cứ lặp lại vậy. Không biết có cần thiết lập gì cho Excel không nữa.
 
Hai Lúa Miền Tây đã viết:
Có thể rút gọn code trên như sau:

Mã: 
Sub ScrollRecords()
    Dim so As Integer, i As Integer
    Application.Cursor = xlIBeam

    With CreateObject("ADODB.Recordset")
        .Open ("Select * from [DS$]"), "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName, 1, 3
        i = 0
        so = .RecordCount
        For i = 0 To so + 1
            .MoveFirst
            .Move i - 1
            Sheet2.Range("F2:G10").ClearContents
            Sheet2.Range("F2").CopyFromRecordset .DataSource, 5, 2
            i = i + 1
            Application.Wait (Now + TimeValue("00:00:01"))
            If i > so Then
                i = 0
                .MoveFirst
            End If
        Next
    End With
 
End Sub

@ongke0711 : Mình thay adOpenDynamic (2) thành adOpenKeyset (1) ở code trên mới có thể chạy được với cách này.
Nhấp chuột vào đây để mở rộng...
Mới thử xong nó chạy kẹt cứng chuột luôn không thoát được
 
ongke0711 đã viết:
Sao trên máy tôi nếu áp dụng kiểu xoá toàn bộ Cell trước khi cập nhật (dùng code của bạn) thì nó nháy hiển thị nội dung rất nhanh, không kịp nhìn, sau đó xoá trắng cell và cứ lặp lại vậy. Không biết có cần thiết lập gì cho Excel không nữa.
Nhấp chuột vào đây để mở rộng...
Bạn chỉnh lại độ trể thời gian xem thế nào nhé.
phuongnam366377 đã viết:
Mới thử xong nó chạy kẹt cứng chuột luôn không thoát được
Nhấp chuột vào đây để mở rộng...
Đúng rồi, vòng lặp vô tận mà anh.
 
Lọc dữ liệu bằng các toán tử sau:

=
<>
>
<
Like x*
Like *x
Like *x*

Rich (BB code): 
Sub Filter_HLMT_1()
    Dim intPage As Integer, i As Integer, intSq As Integer, intRecord As Integer
    Dim lngTotal As Long
    With CreateObject("ADODB.Recordset")
        .Open "Select * from [Sheet1$]", "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName, 1
        .Filter = "Code like '*1*'"
        .PageSize = 20
        Sheet2.Cells.ClearContents
        For intPage = 1 To .PageCount
            lngTotal = 0
            For intRecord = 1 To .PageSize
                i = i + 1
                intSq = intSq + 1
                Sheet2.Range("A" & i) = intSq
                Sheet2.Range("B" & i) = !ID
                Sheet2.Range("C" & i) = !Code
                Sheet2.Range("D" & i) = !Price
                lngTotal = lngTotal + !Price
                .MoveNext
                If .EOF Then Exit For
            Next
            i = i + 1
            Sheet2.Range("C" & i) = "Total:"
            Sheet2.Range("D" & i) = lngTotal
        Next
    End With
End Sub
 
Hai Lúa Miền Tây đã viết:
Lọc dữ liệu bằng các toán tử sau:

=
<>
>
<
Like x*
Like *x
Like *x*

Rich (BB code): 
Sub Filter_HLMT_1()
    Dim intPage As Integer, i As Integer, intSq As Integer, intRecord As Integer
    Dim lngTotal As Long
    With CreateObject("ADODB.Recordset")
        .Open "Select * from [Sheet1$]", "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName, 1
        .Filter = "Code like '*1*'"
        .PageSize = 20
        Sheet2.Cells.ClearContents
        For intPage = 1 To .PageCount
            lngTotal = 0
            For intRecord = 1 To .PageSize
                i = i + 1
                intSq = intSq + 1
                Sheet2.Range("A" & i) = intSq
                Sheet2.Range("B" & i) = !ID
                Sheet2.Range("C" & i) = !Code
                Sheet2.Range("D" & i) = !Price
                lngTotal = lngTotal + !Price
                .MoveNext
                If .EOF Then Exit For
            Next
            i = i + 1
            Sheet2.Range("C" & i) = "Total:"
            Sheet2.Range("D" & i) = lngTotal
        Next
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
khai báo 1 Array Public xong chỉ mở kết nối lần đầu tiên chạy code xong cho toán tử like lên Texbox gõ vào lọc thì tốc độ bay vèo vèo đấy
Ứng dụng lọc khá hay
 
Hai Lúa Miền Tây đã viết:
Khai thác và đưa lên thử đi anh.
Nhấp chuột vào đây để mở rộng...
thì code đó viết lại chút à ... để đó 1 tuần sau cho các thành viên khác tham gia xem sao ... ko có ai ý kiếm chi Mạnh viết lại code đó úp cho
cái chủ yếu ở đây là làm cho nhiều người tham gia ấy nó mới vui và khai thác được nhiều góc khuất khác nhau của ADODB mà ta chưa nhìn ra ... đó mới là cái mà mạnh luôn hướng tới trong cách khai thác và viết code ...vv
 
Hai Lúa Miền Tây đã viết:
Lọc dữ liệu bằng các toán tử sau:

=
<>
>
<
Like x*
Like *x
Like *x*

Rich (BB code): 
Sub Filter_HLMT_1()
...
        .Filter = "Code like '*1*'"
 ...
Nhấp chuột vào đây để mở rộng...

Tôi thấy một cái hạn chế của Filter và Find là chỉ lọc được một điều kiện mỗi lần (không dùng AND và OR được).
Chẳng lẻ dùng Filter của Filter.
 
ongke0711 đã viết:
Tôi thấy một cái hạn chế của Filter và Find là chỉ lọc được một điều kiện mỗi lần (không dùng AND và OR được).
Chẳng lẻ dùng Filter của Filter.
Nhấp chuột vào đây để mở rộng...
Được chứ bạn, ví dụ như sau tôi lọc 2 cột với 2 điều kiện:

Rich (BB code): 
Sub Filter_HLMT_1()
    Dim intPage As Integer, i As Integer, intSq As Integer, intRecord As Integer
    Dim lngTotal As Long
    With CreateObject("ADODB.Recordset")
        .Open "Select * from [Sheet1$]", "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 Xml;Data Source=" & ThisWorkbook.FullName, 1
        .Filter = "Code like '*1*' and Price <950000"
        .PageSize = 20
        Sheet2.Cells.ClearContents
        For intPage = 1 To .PageCount
            lngTotal = 0
            For intRecord = 1 To .PageSize
                i = i + 1
                intSq = intSq + 1
                Sheet2.Range("A" & i) = intSq
                Sheet2.Range("B" & i) = !ID
                Sheet2.Range("C" & i) = !Code
                Sheet2.Range("D" & i) = !Price
                lngTotal = lngTotal + !Price
                .MoveNext
                If .EOF Then Exit For
            Next
            i = i + 1
            Sheet2.Range("C" & i) = "Total:"
            Sheet2.Range("D" & i) = lngTotal
        Next
    End With
End Sub
 
Hai Lúa Miền Tây đã viết:
Được chứ bạn, ví dụ như sau tôi lọc 2 cột với 2 điều kiện:

Rich (BB code): 
        .Filter = "Code like '*1*' and Price <950000"
Nhấp chuột vào đây để mở rộng...

Vậy à. Tôi cũng ít dùng cái này nên cũng chưa biết. :)
Tôi thường hay dùng thẳng trong câu lệnh SQL để giảm bớt dung lượng Recordset trả về, nhưng nếu thường xuyên lọc dữ liệu trong một phiên làm việc thì dùng Filter sẽ nhanh hơn vì dữ liệu đã load về sẳn.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
11
Đọc
353
Thanh Binh111
T
mucongnghenhat
lỗi đoạn văn bản bị đóng khung
Trả lời
0
Đọc
18
mucongnghenhat
mucongnghenhat
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
8
Đọc
562
nguyendang95
N
Uyên dương Hoya
Lỗi định dạng form chữ trong excel
Trả lời
1
Đọc
55
DeTong
D
ntnguyentam1907
Lấy bảng dữ liệu chứng khoán về excel
2
Trả lời
22
Đọc
3K
nguyendang95
N
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Cảm ơn
Trả lời
5
Đọc
754
hoangtuan.net
hoangtuan.net
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
35
Đọc
13K
minhys1
M
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
305
Đọc
21K
pkt.bacdau
pkt.bacdau
HONGVY91
Đếm số lượng 2 cột và đếm không trùng
Trả lời
2
Đọc
114
hoangtuaotrang_hp_vn
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
3
Đọc
180
hanhlx88
hanhlx88
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
3
Đọc
104
VetMini
V
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
73
Đọc
10K
HeSanbi
HeSanbi
L
Folder chứa chương trình bị khóa bởi Lock folder
2
Trả lời
28
Đọc
25K
qthangvphaui
Q
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
4
Đọc
142
phambahoang
P
N
Tính tổng với điều kiện gần đúng
Trả lời
3
Đọc
63
HUONGHCKT
H
Bùi Thúy Thúy
  • Question Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
63
Đọc
19K
Mutants Men
M
Anxseo
  • Đã khóa
Cách crack my excel
Trả lời
1
Đọc
169
HeSanbi
HeSanbi
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
5
Đọc
244
yaaasoo01
Y
anhtuan1066
  • Question Question
Chèn hình vào cell bằng hàm tự tạo
    • Thích
    • Ngạc nhiên
10 11 12
Trả lời
235
Đọc
106K
XaNguyen
X
vc_đi chơi
Khóa Hoặc mã hóa File excel có độ bảo mật cao
    • Cảm ơn
    • Thích
Trả lời
3
Đọc
202
Hoangkhang01213
Hoangkhang01213
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom