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

  • ScollRecords_ADORecordset.xlsm
    25.8 KB · Đọc: 28
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

H
  • Question
Code subtotal và tìm điều kiện
Trả lời
6
Đọc
73
Hoàng Tuấn 868
H
P
  • Question
Nhờ hỗ trợ chọn vùng trong Inputbox ở VBA
Trả lời
13
Đọc
429
Hoàng Tuấn 868
H
H
Xin giúp đỡ lấy lại file excel bị lưu đè
Trả lời
2
Đọc
44
HOANGVO797969
H
kiencuong030184
  • Question
ẩn hiện dòng, cột có điều kiên
Trả lời
3
Đọc
64
SA_DQ
SA_DQ
Emyeuexcel
  • Question
In theo số thứ tự
    • Chấp nhận
Trả lời
6
Đọc
124
Emyeuexcel
Emyeuexcel
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom