Ghi Dữ Liệu Vào File Đóng Bằng ADO

[Kiều Mạnh]

Mình có viết một chương trình Bán hàng...sử dụng VBA để ghi dữ liệu từ file chuơngTrinh.xlsb vào File Data.xlsb hiện tại sử dụng tốt ...
Nhưng khi dữ liệu File Data càng lớn thì thấy nó hơi chậm lại...vì vậy mình muốn chuyển qua sử dụng ADO với code có chức năng tương tự nhưng kẹt chưa làm được ...Vậy úp lên nhờ các Bạn trợ giúp

1/ vùng dữ liệu cần ghi từ File chuongTrinh là [A6:J82]

2/ điều kiện ghi là từ [C6:C82] nếu Cells nào có dữ liệu thì lọc ghi theo dòng đó (khó khúc này ADO là mình Tịt...Nếu ghi nguyên vùng thì OK)

3/ Ghi vào Sheets("Data_Ban")File Data.xlsb nối tiếp xuống dưới tương tự như Code VBA mình viết....sau khi ghi xong thì chay Sub Autpen trong File Data.xlsb
Xin cảm ơn các Bạn đã trợ giúp...
Code VBA

Public Sub LuuData_Ban()
Application.ScreenUpdating = False
Dim Nguon(), Kq(), i&, j&, k&
Nguon = ActiveSheet.Range("A6:J82").Value
ReDim Kq(1 To UBound(Nguon, 1), 1 To UBound(Nguon, 2))
For i = 1 To UBound(Nguon, 1)
    If Nguon(i, 3) <> "" Then 
       k = k + 1
        For j = 1 To UBound(Nguon, 2)
            Kq(k, j) = Nguon(i, j)
        Next
    End If
Next
With Workbooks.Open(ThisWorkbook.Path & "\Data.xlsb", 0)
    .Sheets("Data_Ban").Range("A65536").End(3)(2).Resize(k, UBound(Nguon, 2)) = Kq
    .RunAutoMacros (xlAutoOpen) ''Chay Sub Auto_Open Trong File Data
    .Close True
End With
Application.ScreenUpdating = True
End Sub

 

[doveandrose]

Hãy thử đến mọi trường hợp. Đó cũng là 1 cách.

có phải ý anh là dùng lệnh Update bảng [BanHangB6:N] chăng ?

 

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

có phải ý anh là dùng lệnh Update bảng [BanHangB6:N] chăng ?

Mấu chốt nằm ở chổ cột B sheet BanHang.
Còn rất nhiều cách để xử vụ này, bạn hãy thử cho đến khi tạm gọi là "ngon" nhé.

 

[doveandrose]

Mấu chốt nằm ở chổ cột B sheet BanHang.
Còn rất nhiều cách để xử vụ này, bạn hãy thử cho đến khi tạm gọi là "ngon" nhé.

thì nãy giờ em nêu 2 cách rồi mà
phải làm sao mới xí dụ được anh cho học hỏi 1 đoạn code đây . hức . khó quá

 

[Kiều Mạnh]

Phần bán hàng như vậy là quá tốt rồi....còn Phần Nhập-Xuất-Tồn nó chưa đồng Bộ với Phần Bán hàng vậy mình úp mẫu lên nhờ các bạn trợ giúp

1/ Sheet Nhập-Xuất-Tồn cột tên hàng luôn luôn cập nhật theo cột của sheet BanHang

2/ Tính toán dùm mình theo Mẫu Sheet Nhap-Xuat-Ton (vẫn lấy nguồn Từ File Data)....trong File data viết Bằng VBA thì Mình làm được ...còn ADO lấy lên tính toán thì không làm được ... vậy nhờ các Bạn xử lý dùm

Xin Cảm ơn

 

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

thì nãy giờ em nêu 2 cách rồi mà
phải làm sao mới xí dụ được anh cho học hỏi 1 đoạn code đây . hức . khó quá

ecec, từ đầu đến giờ tôi có viết được code nào ra hồn đâu. Bạn viết không đó chứ, nghe đồn anh Ba Tê "ngon" cái vụ "xí dụ" lắm. Bạn liên hệ ảnh xem sao nhé. ecec....

 

[Kiều Mạnh]

thay Sub Lay_TonKho() cũ bằng Sub này xem mèo nào cắn miu nào ?

Sub Lay_TonKho()
    Dim strTen As String, arr As Variant, r As Long, Dic As Object, dArr As Variant
    Set Cnn = CreateObject("ADODB.Connection")
    Set Dic = CreateObject("Scripting.Dictionary")
    Cnn.Open (Sheet1.Range("A1"))
    Set rst = Cnn.Execute("select f1, sum(f6)-sum(f12) from (select f1,f2 as f6,0 as f12 from [Data_Nhap$B2:C] union all select f1,0 as f6,f2 as f12 from [Data_Ban$B2:C]) group by f1 ")
    dArr = rst.GetRows
    Application.ScreenUpdating = False
    arr = Sheet1.Range("M6:M" & Sheet1.[M6].End(xlDown).Row).Value
    For r = 0 To UBound(dArr, 2) Step 1
        Dic(dArr(0, r)) = dArr(1, r)
    Next
    For r = 1 To UBound(arr) Step 1
        If Dic.exists(arr(r, 1)) Then
            arr(r, 1) = Dic(arr(r, 1))
        Else
            arr(r, 1) = "khong co dau Kieu Manh oi"
        End If
    Next
    Sheet1.Range("N6:N" & Sheet1.[M6].End(xlDown).Row).Value = arr
    Application.ScreenUpdating = True
    Set Cnn = Nothing
    Set rst = Nothing
End Sub

Code bài Này Bạn Viết hay quá ..dùng ADO lấy lên xong Add vào mãng Dic... Kết hợp ADO và Dic Tuyệt Vời
Mình Sửa lại một Tẹo như sau cho Phù hợp với mình

Sub Lay_TonKho22()
    Dim strTen As String, arr As Variant, r As Long, Dic As Object, dArr As Variant
    Set Cnn = CreateObject("ADODB.Connection")
    Set Dic = CreateObject("Scripting.Dictionary")
    Cnn.Open (Sheet1.Range("XFD1"))
    Set rst = Cnn.Execute("select f1, sum(f6)-sum(f12) from (select f1,f2 as f6,0 as f12 from [Data_Nhap$B2:C] union all select f1,0 as f6,f2 as f12 from [Data_Ban$B2:C]) group by f1 ")
    dArr = rst.GetRows
    Application.ScreenUpdating = False
    arr = Sheet1.Range("B6:B82").Value
    For r = 0 To UBound(dArr, 2) Step 1
        Dic(dArr(0, r)) = dArr(1, r)
    Next
    For r = 1 To UBound(arr) Step 1
        If Dic.exists(arr(r, 1)) Then
            arr(r, 1) = Dic(arr(r, 1))
        Else
            arr(r, 1) = Empty
        End If
    Next
    Sheet1.Range("N6:N82").Value = arr
    Application.ScreenUpdating = True
    Set Cnn = Nothing
    Set rst = Nothing
End Sub

 

[Quang_Hải]

Code bài Này Bạn Viết hay quá ..dùng ADO lấy lên xong Add vào mãng Dic... Kết hợp ADO và Dic Tuyệt Vời
Mình Sửa lại một Tẹo như sau cho Phù hợp với mình

Sub Lay_TonKho22()
    Dim strTen As String, arr As Variant, r As Long, Dic As Object, dArr As Variant
    Set Cnn = CreateObject("ADODB.Connection")
    Set Dic = CreateObject("Scripting.Dictionary")
    Cnn.Open (Sheet1.Range("XFD1"))
    Set rst = Cnn.Execute("select f1, sum(f6)-sum(f12) from (select f1,f2 as f6,0 as f12 from [Data_Nhap$B2:C] union all select f1,0 as f6,f2 as f12 from [Data_Ban$B2:C]) group by f1 ")
    dArr = rst.GetRows
    Application.ScreenUpdating = False
    arr = Sheet1.Range("B6:B82").Value
    For r = 0 To UBound(dArr, 2) Step 1
        Dic(dArr(0, r)) = dArr(1, r)
    Next
    For r = 1 To UBound(arr) Step 1
        If Dic.exists(arr(r, 1)) Then
            arr(r, 1) = Dic(arr(r, 1))
        Else
            arr(r, 1) = Empty
        End If
    Next
    Sheet1.Range("N6:N82").Value = arr
    Application.ScreenUpdating = True
    Set Cnn = Nothing
    Set rst = Nothing
End Sub

Theo mình thì:
1. Khai báo kiểu Early Binding (tức là check vào mục Reference) cho code chạy nhanh hơn. Khai báo cũng gọn hơn, khỏi mắc công set này set nọ.
2. Nếu muốn dùng VBA xử lý thì sao không dùng phương thức Getrows lấy tất tần tật lên mảng rồi xử lý, mắc chi phải dùng câu lệnh SQL phức tạp kia làm gì. Chú ý cái mảng sau khi lấy bằng GetRows là mảng ngược nhé.
3. Mình chỉ đoán vậy thôi, nên nếu có trật thì mọi người bỏ qua nhé.

 

[Kiều Mạnh]

Theo mình thì:
1. Khai báo kiểu Early Binding (tức là check vào mục Reference) cho code chạy nhanh hơn. Khai báo cũng gọn hơn, khỏi mắc công set này set nọ.
2. Nếu muốn dùng VBA xử lý thì sao không dùng phương thức Getrows lấy tất tần tật lên mảng rồi xử lý, mắc chi phải dùng câu lệnh SQL phức tạp kia làm gì. Chú ý cái mảng sau khi lấy bằng GetRows là mảng ngược nhé.
3. Mình chỉ đoán vậy thôi, nên nếu có trật thì mọi người bỏ qua nhé.

Em làm gì có khả năng viết được như Anh nói... có chăng 1 -2 năm nữa may ra viết được
Em thấy chạy ok sửa lại một tẹo cho phù hợp thôi mà

 

[Quang_Hải]

Tham gia 1 code cho vui, chứ thật sự không dám ho hen với ADO. Chú ý là phải dùng Early Binding nha. Không check vào running time hoặc không check vào data object* gì đó thì code nó ngu nhá.
*** Lâu rồi không tung chưởng nào hết. Bận quá rồi code cũng biến đi mất. Có chỗ nào không hay thì mọi người góp ý nhé.

Sub Main()
Dim SQL As String, MySheet(), Tmp(), i As Long, j As Long, Arr()
Dim ObjRst As New ADODB.Recordset, ObjConn As New ADODB.Connection, Dic As New dictionary
MySheet = Array("[Data_Nhap$B2:C65536]", "[Data_Ban$B2:C65536]")
Set ObjConn = GetConnection(ThisWorkbook.Path & "\Data.xlsb")
For j = 0 To UBound(MySheet)
   SQL = "select * from " & MySheet(j)
   ObjRst.Open SQL, ObjConn, 3, 1
   Tmp = ObjRst.GetRows
   ObjRst.Close
   GetData Tmp, Dic, j
Next
With Sheets("BanHang")
   Arr = .Range("M6", .[M65536].End(3)).Resize(, 2).Value
End With
For i = 1 To UBound(Arr)
   If Dic.Exists(Arr(i, 1)) Then
      Arr(i, 2) = Dic.Item(Arr(i, 1))
   Else
      Arr(i, 2) = Empty
   End If
Next
Sheets("BanHang").[M6].Resize(i - 1, 2) = Arr
End Sub

Sub GetData(Arr, Dic, j)
Dim i As Long
For i = 0 To UBound(Arr, 2)
   If j = 0 Then
      Dic(Arr(0, i)) = Dic(Arr(0, i)) + Arr(1, i)
   Else
      Dic(Arr(0, i)) = Dic(Arr(0, i)) - Arr(1, i)
   End If
Next
End Sub

Function GetConnection(ByVal Path As String)
Dim StrConn As String, ObjConn As New ADODB.Connection
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" _
& Path & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
ObjConn.Open StrConn
Set GetConnection = ObjConn
End Function

 

[Kiều Mạnh]

Tham gia 1 code cho vui, chứ thật sự không dám ho hen với ADO. Chú ý là phải dùng Early Binding nha. Không check vào running time hoặc không check vào data object* gì đó thì code nó ngu nhá.
*** Lâu rồi không tung chưởng nào hết. Bận quá rồi code cũng biến đi mất. Có chỗ nào không hay thì mọi người góp ý nhé.

Sub Main()
Dim SQL As String, MySheet(), Tmp(), i As Long, j As Long, Arr()
Dim ObjRst As New ADODB.Recordset, ObjConn As New ADODB.Connection, Dic As New dictionary
MySheet = Array("[Data_Nhap$B2:C65536]", "[Data_Ban$B2:C65536]")
Set ObjConn = GetConnection(ThisWorkbook.Path & "\Data.xlsb")
For j = 0 To UBound(MySheet)
   SQL = "select * from " & MySheet(j)
   ObjRst.Open SQL, ObjConn, 3, 1
   Tmp = ObjRst.GetRows
   ObjRst.Close
   GetData Tmp, Dic, j
Next
With Sheets("BanHang")
   Arr = .Range("M6", .[M65536].End(3)).Resize(, 2).Value
End With
For i = 1 To UBound(Arr)
   If Dic.Exists(Arr(i, 1)) Then
      Arr(i, 2) = Dic.Item(Arr(i, 1))
   Else
      Arr(i, 2) = Empty
   End If
Next
Sheets("BanHang").[M6].Resize(i - 1, 2) = Arr
End Sub

Sub GetData(Arr, Dic, j)
Dim i As Long
For i = 0 To UBound(Arr, 2)
   If j = 0 Then
      Dic(Arr(0, i)) = Dic(Arr(0, i)) + Arr(1, i)
   Else
      Dic(Arr(0, i)) = Dic(Arr(0, i)) - Arr(1, i)
   End If
Next
End Sub

Function GetConnection(ByVal Path As String)
Dim StrConn As String, ObjConn As New ADODB.Connection
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" _
& Path & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
ObjConn.Open StrConn
Set GetConnection = ObjConn
End Function

chạy tốt đó anh ... nhưng phải Check Runtime Và Data Object .. nó mới chạy
Kỳ này Anh viết ADO siêu thật

 

[Quang_Hải]

chạy tốt đó anh ... nhưng phải Check Runtime nó mới chạy

Bài 71 có nói rõ mà. Nếu không check vào 2 mục đó thì code nó sẽ ngu ngu.

 

[Kiều Mạnh]

Bài 71 có nói rõ mà. Nếu không check vào 2 mục đó thì code nó sẽ ngu ngu.

Em đọc tới lui code Anh viết ... khúc biết khúc không...... coi như không biết .........Ngu quá..

 

[huuthang_bd]

Góp vui (Chỉ góp vui thôi nha, ngoài ra không có đóng góp gì khác cả)

 

[Kiều Mạnh]

Góp vui (Chỉ góp vui thôi nha, ngoài ra không có đóng góp gì khác cả)

Khiếp mã hóa vậy ..........Nhìn thấy chạy mất dép..........
Phải nói là GPE nhân tài kiệt xuất như lá mùa thu ..........nhưng ít khi lộ bài...

 

[Quang_Hải]

Em đọc tới lui code Anh viết ... khúc biết khúc không...... coi như không biết .........Ngu quá..

Sửa lại vầy xem coi có dễ hiểu hơn không.

Sub Main()
Dim SQL As String, MySheet(), Tmp(), i As Long, j As Long, Arr()
Dim ObjRst As New ADODB.Recordset, ObjConn As New ADODB.Connection, Dic As New dictionary
MySheet = Array("Data_Nhap$", "Data_Ban$")
Set ObjConn = GetConnection(ThisWorkbook.Path & "\Data.xlsb")
For j = 0 To UBound(MySheet)
   SQL = "select * from [" & MySheet(j) & "B2:C65536]"
   ObjRst.Open SQL, ObjConn, 3, 1
   Tmp = ObjRst.GetRows
   ObjRst.Close
   GetData Tmp, Dic, j
Next
With Sheets("BanHang")
   Arr = .Range("M6", .[M65536].End(3)).Resize(, 2).Value
End With
Final Arr, Dic
Sheets("BanHang").[M6].Resize(UBound(Arr), 2) = Arr
End Sub

Sub GetData(Arr, Dic, j)
Dim i As Long, n As Long
For i = 0 To UBound(Arr, 2)
   n = IIf(j = 0, 1, -1)
   Dic(Arr(0, i)) = Dic(Arr(0, i)) + (Arr(1, i) * n)
Next
End Sub

Sub Final(Arr, Dic)
Dim i As Long
For i = 1 To UBound(Arr)
   If Dic.Exists(Arr(i, 1)) Then
      Arr(i, 2) = Dic.Item(Arr(i, 1))
   Else
      Arr(i, 2) = Empty
   End If
Next
End Sub

Function GetConnection(ByVal Path As String)
Dim StrConn As String, ObjConn As New ADODB.Connection
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" _
& Path & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
ObjConn.Open StrConn
Set GetConnection = ObjConn
End Function

 

[ndu96081631]

Phải nói là GPE nhân tài kiệt xuất như lá mùa thu

Câu "nhân tài kiệt xuất như lá mùa thu" nghe.. buồn cười sao ấy
Hổng biết có ai hiểu không?

 

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

Sửa lại vầy xem coi có dễ hiểu hơn không.

Sub Main()
Dim SQL As String, MySheet(), Tmp(), i As Long, j As Long, Arr()
Dim ObjRst As New ADODB.Recordset, ObjConn As New ADODB.Connection, Dic As New dictionary
MySheet = Array("Data_Nhap$", "Data_Ban$")
Set ObjConn = GetConnection(ThisWorkbook.Path & "\Data.xlsb")
For j = 0 To UBound(MySheet)
   SQL = "select * from [" & MySheet(j) & "B2:C65536]"
   ObjRst.Open SQL, ObjConn, 3, 1
   Tmp = ObjRst.GetRows
   ObjRst.Close
   GetData Tmp, Dic, j
Next
With Sheets("BanHang")
   Arr = .Range("M6", .[M65536].End(3)).Resize(, 2).Value
End With
Final Arr, Dic
Sheets("BanHang").[M6].Resize(UBound(Arr), 2) = Arr
End Sub

Sub GetData(Arr, Dic, j)
Dim i As Long, n As Long
For i = 0 To UBound(Arr, 2)
   n = IIf(j = 0, 1, -1)
   Dic(Arr(0, i)) = Dic(Arr(0, i)) + (Arr(1, i) * n)
Next
End Sub

Sub Final(Arr, Dic)
Dim i As Long
For i = 1 To UBound(Arr)
   If Dic.Exists(Arr(i, 1)) Then
      Arr(i, 2) = Dic.Item(Arr(i, 1))
   Else
      Arr(i, 2) = Empty
   End If
Next
End Sub

Function GetConnection(ByVal Path As String)
Dim StrConn As String, ObjConn As New ADODB.Connection
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" _
& Path & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
ObjConn.Open StrConn
Set GetConnection = ObjConn
End Function

Vẫn chưa khắc phục như bài #57

​

tôi đã đề cập.

Tôi chuyển những câu truy vấn ra ngoài sheet (Sheet3). Vẫn chưa vừa ý lắm, còn nhiều chổ cần phải cải tiến.

Code khi mở file:

Option Explicit

Private Sub Workbook_Open()


    Sheet3.Range("B1") = ThisWorkbook.Path & "\"
    Sheet3.Range("B3") = ThisWorkbook.Name
End Sub

Code trong module

Option Explicit

Dim cnn As Object, rst As Object


'Code ghi du lieu hang ban vao file data
Sub Ghi_Xuat_DuLieu()
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open (Sheet3.Range("B4"))
    cnn.Execute (Sheet3.Range("B16"))
    Lay_TonKho
End Sub
'Code tong hop nhap xuat ton tu file data
Sub Tong_Nhap_Xuat_Ton()
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open (Sheet3.Range("B4"))
    Set rst = cnn.Execute(Sheet3.Range("B14"))
    Sheet2.Range("a2").CopyFromRecordset rst
End Sub
'Code lay so luong ton kho tu file data


Sub Lay_TonKho()
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open (Sheet3.Range("B4"))
    Set rst = cnn.Execute("select F1, Ton from (" & Sheet3.Range("B12") & ")")
    Sheet1.Range("M6").CopyFromRecordset rst
End Sub

Ví dụ ở file đính kèm.

 

[toannd18]

Mọi người có thể chỉ cho mình hàm convert từ text sang số trong truy vấn SQL với. Cám ơn các bạn

quần áo trẻ em | quan ao tre em | quần áo sơ sinh | quần áo bé trai | quần áo bé gái | bodysuit carter | quan ao so sinh | quan ao tre em nhap khau

 

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

Mọi người có thể chỉ cho mình hàm convert từ text sang số trong truy vấn SQL với. Cám ơn các bạn

Vậy phải coi dữ liệu của bạn thế nào đã, thường thì ta dùng hàm Val

 

[toannd18]

Cám ơn bạn mình làm được rùi.
Mà truy vấn trên Excel là dựa trên truy vấn Access. Vậy nó có thể áp dụng sử dụng truy vấn crosstab query không.

quần áo trẻ em | quan ao tre em | quần áo sơ sinh | quần áo bé trai | quần áo bé gái | bodysuit carter | quan ao so sinh | quan ao tre em nhap khau