chia table access (3 người xem)

[Hai Lúa Miền Tây]

sao trong vb6 khi gọi dòng mySQL thì không được nhỉ bác Dom, mặc dù em vẫn gán txtREC bằng form!formname!controls.
mySQL = "SELECT tk.ACCOUNT_ID, tk.CR_NAME, tk.CR_AMOUNT, tk.DB_AMOUNT " & _
"FROM tk " & _
"WHERE (((Partition([stt],1,(select top 1 stt from tk order by stt DESC)," & Form!Form12!txtRec & ")) like '" & ctl.ItemData(varItm) & "'));"
báo runtime error 424 object required. kiểm tra mySQL =nothing

Trong VB6? Vậy bạn có thể gửi cái ví dụ đó lên đây được không? Vì cú pháp trong Access và VB6 có khác chút đỉnh.

 

[thang314]

Dim Cn As New ADODB.Connection
Dim Rec As New ADODB.Recordset
Private Sub Form_Load()
strcon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Database.mdb"
Cn.Open strcon
End Sub
Private Sub thoat_Click()
End
End Sub
Sub Tachsheet()
Dim i&, j&, mySQL$, iR&
Dim Arr(), ReArr()
Dim Cn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim oApp As New Excel.Application, oBook As Excel.Workbook, oSheet As Excel.Worksheet
Dim ShCount As Long, RowInput As Long, T
T = Timer
Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Database.mdb"
mySQL = "SELECT tk.ACCOUNT_ID, tk.CR_NAME, tk.CR_AMOUNT, tk.DB_AMOUNT " & _
"FROM tk " & _
"WHERE (((Partition([stt],1,(select top 1 stt from tk order by stt DESC)," & "'" & Form!Form12!txtRec & "'" & ")) like '" & ctl.ItemData(varItm) & "'));"
Rs.Open mySQL, Cn, adOpenStatic, adLockOptimistic
Arr = Rs.GetRows(-1, 1)
Set oBook = oApp.Workbooks.Add
ReDim ReArr(1 To UBound(Arr, 2) + 1, 1 To UBound(Arr, 1) + 1)
iR = 0: ShCount = 0
ReDim ReArr(1 To 300, 1 To UBound(Arr, 1) + 1)
For j = 0 To UBound(Arr, 2)
iR = iR + 1
For i = 0 To UBound(Arr, 1)
ReArr(iR, i + 1) = Arr(i, j)
Next i
If iR = 300 Or j = UBound(Arr, 2) Then
iR = 0
ShCount = ShCount + 1
oBook.Sheets.Add
Set oSheet = oBook.ActiveSheet
oSheet.Name = "TK" & ShCount
oSheet.[A1].Resize(iR, 4) = ReArr
ReDim ReArr(1 To 300, 1 To UBound(Arr, 1) + 1)
End If
Next j
Rs.Close
Cn.Close
Set oBook = Nothing
MsgBox Timer - T
oApp.Visible = True
End Sub
Private Sub Thuchien_Click()
Call Tachsheet
End Sub

bác thông cảm vì project của em có hơn 34 form lận. em phải gửi như này

 

[Hai Lúa Miền Tây]

Bạn có thể tạo ví dụ ở 1 file khác rồi gửi lên, nhìn như thế này khó lắm, phải giả lập dữ liệu để Test.... Mất thời gian lắm.

 

[thang314]

gửi bác project khác nhé. nhờ bác xem hộ

 

[Hai Lúa Miền Tây]

gửi bác project khác nhé. nhờ bác xem hộ

Túm lại bây giờ là bạn muốn xuất từ VB6 sang Excel? Sao có lúc thì bạn nói ở Access? Để khỏi mất thời gian cho bạn cũng như người khác thì quyết định cuối cùng của bạn là gì?

 

[thang314]

chuyện thế này bác à. em phải nhận file của khách hàng rất nhiều, chuyển đổi liên tục về theo file định dạng của công ty. CSDL của công ty em là access nên em import từ excel vào CSDL rồi xuất file chuẩn để trả lại khách hàng. em làm trên vb6.

 

[Hai Lúa Miền Tây]

chuyện thế này bác à. em phải nhận file của khách hàng rất nhiều, chuyển đổi liên tục về theo file định dạng của công ty. CSDL của công ty em là access nên em import từ excel vào CSDL rồi xuất file chuẩn để trả lại khách hàng. em làm trên vb6.

Vẽ Form và các control như hình sau:



Code trong form sẽ là:

Dim Cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Sub TableTemp()
On Error Resume Next
Dim mySQL As String
On Error Resume Next
  mySQL = "Drop table tblTemp"
     Cn.Execute mySQL
     mySQL = "SELECT TK.STT, TK.ACCOUNT_ID, TK.CR_NAME, TK.CR_AMOUNT, TK.DB_AMOUNT, " & _
              "Partition([stt],1,(select top 1 stt from tk order by stt DESC)," & txtREC & ") AS DK INTO tblTemp " & _
              "FROM TK;"

  rs.Open mySQL, Cn, 1, 3
rs.Close

End Sub
Private Sub cmdNapList_Click()
On Error Resume Next
Dim mySQL As String
mySQL = "SELECT tblTemp.DK From tblTemp GROUP BY tblTemp.DK"
TableTemp
    lstDK.Clear
    If rs.State = 1 Then rs.Close
    rs.Open mySQL, Cn, 3, 3
    If rs.RecordCount = 0 Then
      Exit Sub
    Else
        Do While Not rs.EOF
            lstDK.AddItem rs!dk
            rs.MoveNext
        Loop
    End If
rs.Close
End Sub

Private Sub cmdTachSheet_Click()
On Error Resume Next
Dim oApp As New Excel.Application, oBook As Excel.Workbook, oSheet As Excel.Worksheet
Dim i As Integer, iNumCols As Integer, i1 As Integer, mySQL As String, strDK As String
Set oBook = oApp.Workbooks.Add
For i1 = 0 To lstDK.ListCount - 1
    If lstDK.Selected(i1) = True Then
        lstDK.ListIndex = i1
        strDK = lstDK.Text
    
        mySQL = "SELECT tblTemp.STT, tblTemp.ACCOUNT_ID, tblTemp.CR_NAME, tblTemp.CR_AMOUNT, tblTemp.DB_AMOUNT " & _
            "FROM tbltemp " & _
            "WHERE dk like '" & strDK & "';"
        rs.Open mySQL, Cn, 1, 3
        iNumCols = rs.Fields.Count
        oBook.Sheets.Add
        Set oSheet = oBook.ActiveSheet
            oSheet.Name = "Dom" & Replace(Trim(strDK), ":", "-")
                For i = 1 To iNumCols
                  With oSheet
                    .Cells(5, i).Value = rs.Fields(i - 1).Name
                    .Cells(5, i).Font.Bold = True
                    .Cells(5, i).Font.ColorIndex = 5
                    .Cells(5, i).Interior.ColorIndex = 34
                  End With
                Next
    
            oSheet.Range("A6").CopyFromRecordset rs
            oSheet.Columns.AutoFit
            lstDK.Selected(i1) = False
        rs.Close
    End If
Next i1

For Each sh In oBook.Sheets
    If Left(sh.Name, 3) <> "Dom" Then sh.Delete
Next
oApp.Visible = True


End Sub

Private Sub Form_Load()
strcon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Dom.mdb"
Cn.Open strcon
 cmdNapList_Click
End Sub
Private Sub chkAll_Click()
Dim i As Integer
If chkAll.Value = 1 Then
chkAll.Caption = "Bo chon tat ca"
For i = lstDK.ListCount - 1 To 0 Step -1
        lstDK.ListIndex = i
        lstDK.Selected(i) = True
Next i
Else
chkAll.Caption = "Tat ca"
For i = lstDK.ListCount - 1 To 0 Step -1
        lstDK.ListIndex = i
        lstDK.Selected(i) = False
Next i

End If

End Sub

 

[thang314]

không được rồi bác Dom à. kết quả thu được là:
lại không có các dòng đính kèm như file kèm theo

 

[Hai Lúa Miền Tây]

Bạn xem ví dụ file của mình làm nhé.

 

[thang314]

của bác cũng vậy. chỉ có được tiêu đề còn các record có xuất được đâu ?

 

[Hai Lúa Miền Tây]

của bác cũng vậy. chỉ có được tiêu đề còn các record có xuất được đâu ?

Bạn thử bỏ những dòng On Error Resume Next trong code thử rồi chạy coi nó có báo lỗi ở đâu không nhé.
Mình đảm bảo máy mình và test thử máy của 1 người bạn ok.

 

[thang314]

lỗi Run_time error 430: class does not support automation or does not support expected interface.
lỗi dòng này bác à.
oSheet.Range("A6").CopyFromRecordset rs

 

[Hai Lúa Miền Tây]

lỗi Run_time error 430: class does not support automation or does not support expected interface.
lỗi dòng này bác à.
oSheet.Range("A6").CopyFromRecordset rs

Bạn vào references của nó xem coi có cái nào missing không nhé

 

[thang314]

cái references của em đủ mà. em cũng đã check lại các references nhưng không có thiếu cái nào cả. vì nó còn ra cả bảng excel rồi mà.

 

[nguoiconxunui]

to your project properties, select "Component" tab and check "Binary ..."
option.

 

[thang314]

không có gì mới chán chứ bác à.

 

[nguoiconxunui]

bạn thêm ref MS DAO 3.6.x vào thử xem

 

[thang314]

tiếc rằng không được. không biết lỗi gì nữa.

 

[thang314]

MS DAO 3.6.x có liên quan gì ở đây đâu bác???

 

[thang314]

em đành làm theo cách củ chuối vậy. gọi form access trong vb6 ...