maytinhvp01
Thành viên thường trực
- Tham gia
- 27/7/13
- Bài viết
- 390
- Được thích
- 179
Mã:
Private Sub DATATK_Click()
Dim cn As Object
Dim rs As Object
Dim mysql As String, arrDD1, arrDD2, arrTP1, arrTP2, TP1, TP2, TP, kk
Dim oXl As Object
Dim oXlWb As Object
Dim oXLSheet As Object
Dim dic As Object, i As Long, j As Long, temp As String
'----------------------
'lay mang du lieu cua TKDD
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.ConnectionString = "Data Source= " & App.Path & "/DRAFTKDD.xlsm; Extended Properties=""Excel 12.0;HDR=Yes;"";"
cn.CursorLocation = 3
cn.open
mysql = "SELECT Ma_so_san_pham,C_doan,DVSX,DD FROM [sheet1$] "
rs.open mysql, cn, 3, 3
arrDD1 = rs.getrows()
arrDD2 = soaymang(arrDD1)
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
'-----------------------
'lay mang du lieu cua DRAFTKTP
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.ConnectionString = "Data Source= " & App.Path & "/DRAFTKTP.xlsm; Extended Properties=""Excel 12.0;HDR=Yes;"";"
cn.CursorLocation = 3
cn.open
mysql = "SELECT Ma_so_san_pham,C_doan,DVSX,HT,LK,TP,CLGH FROM [sheet1$] "
rs.open mysql, cn, 3, 3
arrTP1 = rs.getrows()
arrTP2 = soaymang(arrTP1)
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
'-----------------------
'lay mang du lieu cua TKTP
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.ConnectionString = "Data Source= " & App.Path & "/TK.xlsm; Extended Properties=""Excel 12.0;HDR=Yes;"";"
cn.CursorLocation = 3
cn.open
mysql = "SELECT Ma_so_san_pham,C_doan,K_nhan,DVSX,DD,HT,LK,TP,CLGH,Tong FROM [sheet1$] "
rs.open mysql, cn, 3, 3
TP1 = rs.getrows()
TP2 = soaymang(TP1)
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
'-----------------------
'xu ly so lieu tu DRAFTKDD ve mang
Set dic = CreateObject("Scripting.dictionary")
For i = 0 To UBound(TP2)
If (Not dic.Item(TP2(i, 0) & TP2(i, 1))) And (TP2(i, 1) <> "") Then
[COLOR=#ff0000] dic.Add (TP2(i, 0) & TP2(i, 1)), i[/COLOR]
End If
Next
For i = 1 To UBound(arrDD2)
If dic.Item(arrDD2(i, 0) & arrDD2(i, 1)) Then
TP2(dic.Item(arrDD2(i, 0) & arrDD2(i, 1)), 3) = TP2(dic.Item(arrDD2(i, 0) & arrDD2(i, 1)), 3) + arrDD2(i, 2)
TP2(dic.Item(arrDD2(i, 0) & arrDD2(i, 1)), 4) = TP2(dic.Item(arrDD2(i, 0) & arrDD2(i, 1)), 4) + arrDD2(i, 3)
End If
Next
'-------------------------
'xu ly so lieu tu DRAFTKTP ve mang
dic.removeall
For i = 1 To UBound(TP2)
If (Not dic.Item(TP2(i, 0))) And (TP2(i, 2) = "LK1" Or TP2(i, 2) = "HT") Then
dic.Add TP2(i, 0), i
End If
Next
For i = 1 To UBound(arrTP2)
If dic.Item(arrTP2(i, 0)) Then
TP2(dic.Item(arrTP2(i, 0)), 3) = TP2(dic.Item(arrTP2(i, 0)), 3) + arrTP2(i, 2)
TP2(dic.Item(arrTP2(i, 0)), 5) = TP2(dic.Item(arrTP2(i, 0)), 4) + arrTP2(i, 3)
TP2(dic.Item(arrTP2(i, 0)), 6) = TP2(dic.Item(arrTP2(i, 0)), 5) + arrTP2(i, 4)
TP2(dic.Item(arrTP2(i, 0)), 7) = TP2(dic.Item(arrTP2(i, 0)), 6) + arrTP2(i, 5)
TP2(dic.Item(arrTP2(i, 0)), 8) = TP2(dic.Item(arrTP2(i, 0)), 7) + arrTP2(i, 6)
End If
Next
'-------------------------
'cong tong mang TP
For i = 1 To UBound(TP2)
TP2(i, 9) = TP2(i, 3) + TP2(i, 4) + TP2(i, 5) + TP2(i, 6) + TP2(i, 7) + TP2(i, 8)
Next
'----------------------------
'tra lai du lieu ve bang TP
Set oXl = CreateObject("excel.application")
Set oXlWb = oXl.workbooks.open(App.Path & "\TK.xlsm")
Set oXLSheet = oXlWb.Worksheets(1)
TP2 = oXLSheet.range("A2:M" & UBound(TP2))
For i = 1 To UBound(TP2)
For j = 7 To 13
TP(i, j) = TP2(i, j - 4)
Next
Next
oXLSheet.range("A2:M" & UBound(TP2)) = TP
oXl.quit
End SubMục đích của mình là kết nối ADO và lấy về 3 mảng của 3 file rồi xử lý số liệu xong đưa lại kết quả về 1 file " mình viết trên VB6"
Vì file viết nặng rồi nên không gửi lên được ai biết nguyên do cho hỏi tại sao sinh lỗi trên
