mình lỗi vi phạm đăng bài vậy mình tự xóa rồi post lại bài hả bạn
Bạn thử file này xem có được không nhé.
hay quá cám ơn bạn rất nhiều
Dữ liệu mà nhiều hơn thì nó trả kết quả đúng không anh ơi
Chà...! Này mà nhiều A00.... làm code lọc xỉu mệt ak ^^!
Dữ liệu nhiều hơn thì bạn nên tách riêng từng nhóm ra.
đúng rồi dữ liệu rất nhiều đây là bảng mô tả ít thôi, mình đang nghiên cứu cách mà chưa ra
dữ liệu rất nhiều nên không đúng, mình đang test cách mình làm nhưng chưa ra kết quả
Bạn cũng có thể sử dụng cách này để lọc nhiều dữ liệu hơn. Bạn dùng Remove Duplicates để lọc ra 1 DS không trùng Tên nguyên liệu, xác định dòng cuối mỗi lần thêm dòng, cứ thế mà nó sẽ chèn tới dữ liệu mình setup. Từ đó sẽ giải được bài toán này. Do mình đang khá bận nên chưa làm file dc, có thời gian mình làm cho !
Cám ơn bạn nhiều, mình đang code thử mà chưa dc tại mình cần xuất ra giống vậy
Option Explicit
Sub QueryData()
On Error GoTo EH
Application.ScreenUpdating = False
Dim oDuLieuRst As Object, oTenNLRst As Object
Dim sDulieuNR As String
Dim sDBFullPath As String, sTenNLSql As String, sDuLieuSql As String
Dim lngDestRow As Long, rstTotalRow As Long, rstFR As Long, rstLR As Long
'Ket noi toi file du lieu - là chính file Excel này
sDBFullPath = ThisWorkbook.FullName
ConnectDB sDBFullPath
'Xác dinh vùng du lieu can lay - dung cho cau lenh SQL
Dim lastRow As Long
lastRow = Sheet1.Cells(Sheet1.Rows.Count, 6).End(xlUp).Row
sDulieuNR = "A2:F" & lastRow
'Loc tên mã sô duy nhat dua vao recordset rieng
sTenNLSql = "SELECT DISTINCT MaSo, TenNL FROM " & sDulieuNR & " ORDER BY MaSo"
Set oTenNLRst = GetADORecordset(sTenNLSql)
Sheet1.Range("K4:O10000").ClearContents
lngDestRow = 4
oTenNLRst.MoveFirst
Do Until oTenNLRst.EOF
Sheet1.Range("K" & lngDestRow).Value = oTenNLRst!TenNL
Sheet1.Range("L" & lngDestRow).Value = oTenNLRst!MaSo
Sheet1.Range("K" & lngDestRow & ":L" & lngDestRow).Font.Bold = True
'Lay du lieu có cung Mã so
sDuLieuSql = "SELECT SoLo, NhaSX, NgayDuyet, TinhTrang FROM " & sDulieuNR & " WHERE MaSo Like '" & oTenNLRst!MaSo & "' ORDER BY SoLo"
Set oDuLieuRst = GetADORecordset(sDuLieuSql)
rstTotalRow = oDuLieuRst.RecordCount 'Tomg so dong cua Recordset vua filter
rstFR = lngDestRow + 1
rstLR = rstFR + rstTotalRow - 1
Sheet1.Range("L" & rstFR & ":O" & rstLR).Value = WorksheetFunction.Transpose(oDuLieuRst.getrows)
lngDestRow = lngDestRow + rstTotalRow + 1
oTenNLRst.MoveNext
Loop
oTenNLRst.Close
oDuLieuRst.Close
Set oDuLieuRst = Nothing
Set oTenNLRst = Nothing
Application.ScreenUpdating = True
EH_Exit:
Exit Sub
EH:
MsgBox "Có loi phat sinh." & vbNewLine & vbNewLine & _
"Ma loi: " & Err.Number & vbNewLine & _
"Noi dung loi: " & Err.Description, vbCritical, "Query Data Error"
Set oDuLieuRst = Nothing
Set oTenNLRst = Nothing
Resume EH_Exit
End SubOption Explicit
Private Const adUseClient As Long = 3
Private Const adLockReadOnly As Long = 1
Private Const adStateOpen As Long = 1
Private Const adCmdStoredProc As Long = 4
Private Const adParamOutput As Long = 2
Private Const adOpenDynamic As Long = 2
Private Const adOpenStatic As Long = 3
Private Const adCmdText = &H1
Private Const adCmdTable = 2
Global oCnn As Object
Public Function ConnectDB(strWBFullName As String) As Boolean
On Error GoTo ConnectDBError
Dim strConn As String
Dim blnNewConnect As Boolean
Dim blnReturn As Boolean
blnReturn = True
blnNewConnect = True
If Not oCnn Is Nothing Then 'Kiem tra xem có Connection chua, có rôi thi dung ket noi cu
If oCnn.State And adStateOpen = adStateOpen Then '-> Da có ket noi
blnNewConnect = False
End If
End If
If Val(Application.Version) < 12 Then
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWBFullName & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";" 'HDR = No
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWBFullName & ";" & _
"Extended Properties=""Excel 12.0 XML;HDR=Yes"";" 'HDR = No
End If
If blnNewConnect Then
Set oCnn = CreateObject("ADODB.Connection")
oCnn.ConnectionString = strConn
oCnn.Open
End If
ConnectDBResume:
ConnectDB = blnReturn
Exit Function
ConnectDBError:
blnReturn = False
MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number _
& "Noi dung: " & Err.Description, vbCritical, "ConnectDB"
Resume ConnectDBResume
End Function
Sub CloseMyConnection()
On Error GoTo HandleError
oCnn.Close
Set oCnn = Nothing
Exit Sub
HandleError:
If Err > 0 Then
MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number _
& "Noi dung: " & Err.Description, vbCritical, "ConnectDB"
Exit Sub
End If
End Sub
Function GetADORecordset(strRst As String, Optional strSortFld As String) As Object 'ADODB.Recordset
On Error GoTo EH
Dim oRst As Object
Set oRst = CreateObject("ADODB.Recordset")
With oRst
.CursorLocation = adUseClient
.Open strRst, oCnn, adOpenDynamic, adLockReadOnly, adCmdText
If oRst.EOF And oRst.BOF Then
'MsgBox "Không có du lieu."
Set GetADORecordset = Nothing
Exit Function
End If
.Sort = strSortFld
.MoveFirst
End With
Set GetADORecordset = oRst
Exit Function
EH:
MsgBox "Có loi phat sinh." & vbNewLine & vbNewLine & _
"Ma loi: " & Err.Number & vbNewLine & _
"Noi dung loi: " & Err.Description, vbCritical, "GetADORecordset Function Error"
Set GetADORecordset = Nothing
Exit Function
End Function
Bạn thukhon2014 làm thừa cột mã số đúng ra PivotTable phải làm như hình.
xin hỏi bácĐóng góp một cách khác xử lý bằng câu lênh SQL (dùng ADO kết nối dữ liệu)
Tôi chỉ lấy dữ liệu ra theo yêu cầu trên hình còn việc định dạng Cell thì không rành và còn một cái chưa làm được trong đây là đánh số thứ tự. Mấy bạn rành code VBA Excel thì chuyện này chắc xử lý 30 giây, nhờ các bạn hỗ trợ giùm phần này.
- Trong bảng dữ liệu tôi có thêm tên các cột bằng tiếng Việt (không dấu, không khoảng trắng) để tiện việc truy vấn đích danh tên cột (Field) trong vùng dữ liệu. Có thể không dùng tên cột mà thay bằng bí danh như F1, F2... nhưng sau này có thể phát sinh thay đổi vị trí cột thì phải sửa nhiều trong câu lênh SQL nên tôi không dùng cách này.
- Code cho việc truy vấn dữ liệu:
Mã:Option Explicit Sub QueryData() On Error GoTo EH Application.ScreenUpdating = False Dim oDuLieuRst As Object, oTenNLRst As Object Dim sDulieuNR As String Dim sDBFullPath As String, sTenNLSql As String, sDuLieuSql As String Dim lngDestRow As Long, rstTotalRow As Long, rstFR As Long, rstLR As Long 'Ket noi toi file du lieu - là chính file Excel này sDBFullPath = ThisWorkbook.FullName ConnectDB sDBFullPath 'Xác dinh vùng du lieu can lay - dung cho cau lenh SQL Dim lastRow As Long lastRow = Sheet1.Cells(Sheet1.Rows.Count, 6).End(xlUp).Row sDulieuNR = "A2:F" & lastRow 'Loc tên mã sô duy nhat dua vao recordset rieng sTenNLSql = "SELECT DISTINCT MaSo, TenNL FROM " & sDulieuNR & " ORDER BY MaSo" Set oTenNLRst = GetADORecordset(sTenNLSql) Sheet1.Range("K4:O10000").ClearContents lngDestRow = 4 oTenNLRst.MoveFirst Do Until oTenNLRst.EOF Sheet1.Range("K" & lngDestRow).Value = oTenNLRst!TenNL Sheet1.Range("L" & lngDestRow).Value = oTenNLRst!MaSo Sheet1.Range("K" & lngDestRow & ":L" & lngDestRow).Font.Bold = True 'Lay du lieu có cung Mã so sDuLieuSql = "SELECT SoLo, NhaSX, NgayDuyet, TinhTrang FROM " & sDulieuNR & " WHERE MaSo Like '" & oTenNLRst!MaSo & "' ORDER BY SoLo" Set oDuLieuRst = GetADORecordset(sDuLieuSql) rstTotalRow = oDuLieuRst.RecordCount 'Tomg so dong cua Recordset vua filter rstFR = lngDestRow + 1 rstLR = rstFR + rstTotalRow - 1 Sheet1.Range("L" & rstFR & ":O" & rstLR).Value = WorksheetFunction.Transpose(oDuLieuRst.getrows) lngDestRow = lngDestRow + rstTotalRow + 1 oTenNLRst.MoveNext Loop oTenNLRst.Close oDuLieuRst.Close Set oDuLieuRst = Nothing Set oTenNLRst = Nothing Application.ScreenUpdating = True EH_Exit: Exit Sub EH: MsgBox "Có loi phat sinh." & vbNewLine & vbNewLine & _ "Ma loi: " & Err.Number & vbNewLine & _ "Noi dung loi: " & Err.Description, vbCritical, "Query Data Error" Set oDuLieuRst = Nothing Set oTenNLRst = Nothing Resume EH_Exit End Sub
- Các hàm dùng trong Sub QueryData().
Mã:Option Explicit Private Const adUseClient As Long = 3 Private Const adLockReadOnly As Long = 1 Private Const adStateOpen As Long = 1 Private Const adCmdStoredProc As Long = 4 Private Const adParamOutput As Long = 2 Private Const adOpenDynamic As Long = 2 Private Const adOpenStatic As Long = 3 Private Const adCmdText = &H1 Private Const adCmdTable = 2 Global oCnn As Object Public Function ConnectDB(strWBFullName As String) As Boolean On Error GoTo ConnectDBError Dim strConn As String Dim blnNewConnect As Boolean Dim blnReturn As Boolean blnReturn = True blnNewConnect = True If Not oCnn Is Nothing Then 'Kiem tra xem có Connection chua, có rôi thi dung ket noi cu If oCnn.State And adStateOpen = adStateOpen Then '-> Da có ket noi blnNewConnect = False End If End If If Val(Application.Version) < 12 Then strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & strWBFullName & ";" & _ "Extended Properties=""Excel 8.0;HDR=Yes"";" 'HDR = No Else strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & strWBFullName & ";" & _ "Extended Properties=""Excel 12.0 XML;HDR=Yes"";" 'HDR = No End If If blnNewConnect Then Set oCnn = CreateObject("ADODB.Connection") oCnn.ConnectionString = strConn oCnn.Open End If ConnectDBResume: ConnectDB = blnReturn Exit Function ConnectDBError: blnReturn = False MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number _ & "Noi dung: " & Err.Description, vbCritical, "ConnectDB" Resume ConnectDBResume End Function Sub CloseMyConnection() On Error GoTo HandleError oCnn.Close Set oCnn = Nothing Exit Sub HandleError: If Err > 0 Then MsgBox "Có loi phat sinh." & vbCrLf & "Ma loi: " & Err.Number _ & "Noi dung: " & Err.Description, vbCritical, "ConnectDB" Exit Sub End If End Sub Function GetADORecordset(strRst As String, Optional strSortFld As String) As Object 'ADODB.Recordset On Error GoTo EH Dim oRst As Object Set oRst = CreateObject("ADODB.Recordset") With oRst .CursorLocation = adUseClient .Open strRst, oCnn, adOpenDynamic, adLockReadOnly, adCmdText If oRst.EOF And oRst.BOF Then 'MsgBox "Không có du lieu." Set GetADORecordset = Nothing Exit Function End If .Sort = strSortFld .MoveFirst End With Set GetADORecordset = oRst Exit Function EH: MsgBox "Có loi phat sinh." & vbNewLine & vbNewLine & _ "Ma loi: " & Err.Number & vbNewLine & _ "Noi dung loi: " & Err.Description, vbCritical, "GetADORecordset Function Error" Set GetADORecordset = Nothing Exit Function End Function
View attachment 229722
Nghề tôi thì không liên quan đến lập trình rồi (chuyên về marketing) nhưng cũng có đam mê nên tự tìm tòi học hỏi thôi. Một phần cũng có liên quan là trước đây công việc cần tổng hợp, phân tích các số liệu kinh doanh để làm kế hoạch nên mới mày mò Access và xin IT cho kết nối với Server của Cty để lấy dữ liệu theo yêu cầu cho nhanh. Nói chung là có mục đích viết cái ứng dụng cụ thể để phục vụ cho công việc bản thân một cách hiệu quả hơn từ đó sẽ có động lực tìm tòi, học hỏi để hoàn thành nó. Chỉ vậy thôi.
