Sử dụng VBA gộp 2 file excel và Xử lý dữ liệu (1 người xem)

[ngocuytk7]

Xin chào mọi người.
1.Mình muốn lập trình VBA xử lý gộp 2 file excel mình đính kèm thành 1 file.
2.Mình muốn IN ra một file tổng hợp như sau

Họ Tên Ngày Sinh Giới Tính Phương thức gửi Đã nhận
Nguyễn Văn A 10/10/2013 Namb Email OK
Nguyễn Thị B 11/11/2013 Nữ SMS Not

Trường hợp Nguyễn Văn A ở file Email (Đã nhận =OK) còn Nguyễn Văn A ở SMS(Đã nhận=NOt) thì khi In ra file tonghop thì Nguyễn Văn A là (Đã nhận = OK)

Trường hợp Nguyễn Văn B ở file Email (Đã nhận =Not) còn Nguyễn Văn A ở SMS(Đã nhận=NOt) thì khi In ra file tonghop thì Nguyễn Văn A là (Đã nhận = Not)

Mình xin cảm ơn mọi người nhiều.

 

[Quang_Hải]

Xin chào mọi người.
1.Mình muốn lập trình VBA xử lý gộp 2 file excel mình đính kèm thành 1 file.
2.Mình muốn IN ra một file tổng hợp như sau

Họ Tên Ngày Sinh Giới Tính Phương thức gửi Đã nhận
Nguyễn Văn A 10/10/2013 Namb Email OK
Nguyễn Thị B 11/11/2013 Nữ SMS Not

Trường hợp Nguyễn Văn A ở file Email (Đã nhận =OK) còn Nguyễn Văn A ở SMS(Đã nhận=NOt) thì khi In ra file tonghop thì Nguyễn Văn A là (Đã nhận = OK)

Trường hợp Nguyễn Văn B ở file Email (Đã nhận =Not) còn Nguyễn Văn A ở SMS(Đã nhận=NOt) thì khi In ra file tonghop thì Nguyễn Văn A là (Đã nhận = Not)

Mình xin cảm ơn mọi người nhiều.

Bạn tải file về lưu cùng thư mục với 2 file kia rồi bấm nút
.................................
ADO mình còn vụng quá, anh em nào thấy có gì không ổn thì góp ý giúp phần code truy xuất dữ liệu này

Function GetExcelConnection(ByVal Path As String, Optional ByVal Header As Boolean = True)
    Dim StrConn As String, ObjConn As Object, Pro As String, Ext As String
    Set ObjConn = CreateObject("ADODB.Connection")
    If Application.Version < 12 Then
        Pro = "Provider=Microsoft.JET.OLEDB.4.0;"
        Ext = ";Extended Properties=""Excel 8.0;"
    Else
        Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
        Ext = ";Extended Properties=""Excel 12.0;"
    End If
    StrConn = Pro & "Data Source=" & Path & Ext & "HDR=" & IIf(Header, "Yes", "No") & ";IMEX=1"";"
    ObjConn.Open StrConn
    Set GetExcelConnection = ObjConn
End Function

Sub Main()
Dim ObjConn As Object, RS As Object, Files
Dim StrRequest As String, Path As String, I
Path = ThisWorkbook.Path
Files = Array("SMS.xlsx", "Email.xlsx")
Set RS = CreateObject("ADODB.Recordset")
Sheet1.[A2:E10000].ClearContents
    For I = 0 To UBound(Files)
        Set ObjConn = GetExcelConnection(Path & "\" & Files(I), 0)
        StrRequest = "SELECT * FROM [Sheet1$A2:E10000]"
        RS.Open StrRequest, ObjConn, 3, 1
        Sheet1.[A65536].End(3).Offset(1).CopyFromRecordset RS
        ObjConn.Close
    Next
    Set RS = Nothing
End Sub

 

[ngocuytk7]

Cảm ơn bạn đã giúp đỡ.
Bạn cho mình hỏi code này chỉ là gộp file thôi hay có cả xử lý như mình nói nhỉ.
Mình chạy thì thấy gộp file vào chứ chưa có xử lý.hihi
Cảm ơn bạn nhiều

 

[Quang_Hải]

Cảm ơn bạn đã giúp đỡ.
Bạn cho mình hỏi code này chỉ là gộp file thôi hay có cả xử lý như mình nói nhỉ.
Mình chạy thì thấy gộp file vào chứ chưa có xử lý.hihi
Cảm ơn bạn nhiều

File của bạn có 2 dòng. 2 file gộp lại là 4 dòng, xử lý xong còn 2 dòng. File của bạn mà bạn còn không hiểu thì ai hiểu?

 

[ngocuytk7]

File của bạn có 2 dòng. 2 file gộp lại là 4 dòng, xử lý xong còn 2 dòng. File của bạn mà bạn còn không hiểu thì ai hiểu?

Mình chạy như bạn nói rồi mà không được.
Mình mới tìm hiểu VBA nên chưa rõ lắm, bạn có thể chỉ cho mình được không.
Mình gửi bạn lỗi nha.Đây là file của bạn mình chạy luôn.
Xin cảm ơn bạn nhiều.

 

[Quang_Hải]

Mình chạy như bạn nói rồi mà không được.
Mình mới tìm hiểu VBA nên chưa rõ lắm, bạn có thể chỉ cho mình được không.
Mình gửi bạn lỗi nha.Đây là file của bạn mình chạy luôn.
Xin cảm ơn bạn nhiều.

Đoán là bạn chưa có Enabe Macros nên code nó không thể hoạt động được

 

[ngocuytk7]

Đoán là bạn chưa có Enabe Macros nên code nó không thể hoạt động được

hihi. Cảm ơn bạn nhiều.
Có gì mong bạn giúp đỡ tiếp cho mọi người.
Thanks.

 

[ngocuytk7]

Bạn ơi cho mình hỏi ban đầu số cột là 5 nếu tăng số cột lên tầm 20 cột thì đoạn code này sửa như thế nào.
Xin cảm ơn bạn nhiều.
Option Explicit
Sub Main()
Dim ObjConn As Object, RS As Object, Files
Dim StrRequest As String, Path As String, I
Path = ThisWorkbook.Path
Files = Array("SMS.xls", "Email.xls")
Set RS = CreateObject("ADODB.Recordset")
Sheet1.[A2:E10000].ClearContents
For I = 0 To UBound(Files)
Set ObjConn = GetExcelConnection(Path & "\" & Files(I), 0)
StrRequest = "SELECT * FROM [Worksheet$A2:E10000]"
RS.Open StrRequest, ObjConn, 3, 1
Sheet1.[A65536].End(3).Offset(1).CopyFromRecordset RS
ObjConn.Close
Next
Set RS = Nothing
XuLy
End Sub
Sub XuLy()
Dim data(), Res(), I, J, k, Tmp, X
With Sheet1
data = .Range(.[A2], .[E65536].End(3)).Value
ReDim Res(1 To UBound(data), 1 To 6)
End With
With CreateObject("scripting.dictionary")
For I = 1 To UBound(data)
Tmp = data(I, 1) & data(I, 2) & data(I, 3)
If Not .exists(Tmp) Then
k = k + 1
.Add Tmp, k
For J = 1 To 6
Res(k, J) = data(I, J)
Next
Else
X = .Item(Tmp)
If Res(X, 6) <> data(I, 6) Then
If data(I, 5) = "OK" Then
Res(X, 4) = data(I, 4)
Res(X, 5) = "OK"
End If
End If
End If
Next
End With
Sheet1.[A2].Resize(I - 1, 6) = Res
End Sub

 

[phihndhsp]

Function GetExcelConnection(ByVal Path As String, Optional ByVal Header As Boolean = True)
    Dim StrConn As String, ObjConn As Object, Pro As String, Ext As String
    Set ObjConn = CreateObject("ADODB.Connection")
    If Application.Version < 12 Then
        Pro = "Provider=Microsoft.JET.OLEDB.4.0;"
        Ext = ";Extended Properties=""Excel 8.0;"
    Else
        Pro = "Provider=Microsoft.ACE.OLEDB.12.0;"
        Ext = ";Extended Properties=""Excel 12.0;"
    End If
    StrConn = Pro & "Data Source=" & Path & Ext & "HDR=" & IIf(Header, "Yes", "No") & ";IMEX=1"";"
    ObjConn.Open StrConn
    Set GetExcelConnection = ObjConn
End Function

Sub Main()
Dim ObjConn As Object, RS As Object, Files
Dim StrRequest As String, Path As String, I
Path = ThisWorkbook.Path
Files = Array("SMS.xlsx", "Email.xlsx")
Set RS = CreateObject("ADODB.Recordset")
Sheet1.[A2:E10000].ClearContents
    For I = 0 To UBound(Files)
        Set ObjConn = GetExcelConnection(Path & "\" & Files(I), 0)
        StrRequest = "SELECT * FROM [Sheet1$A2:E10000]"
        RS.Open StrRequest, ObjConn, 3, 1
        Sheet1.[A65536].End(3).Offset(1).CopyFromRecordset RS
        ObjConn.Close
    Next
    Set RS = Nothing
End Sub

ObjConn.Open StrConn
Xin Mượn code anh quanghai 1 tí, em không hiểu tại sao chỗ kết nối em có bôi màu đỏ , em thấy đúng hết các tham số, mà sao có máy chạy được, có máy lại báo lỗi chỗ đó, do hôm nay khách hàng có yêu cầu dạng như vậy em lấy bí kíp ra dợt vài đường tất cả các file điều bị lỗi như vậy nhưng qua 3 máy khác thì ok, em lên diễn đàn thử file của anh cũng bị trình trạng như vậy, xin hỏi anh có phải là do office của em cài thiếu cái gì không? cảm ơn anh nhiều
Hinh minh họa

 

[Quang_Hải]

ObjConn.Open StrConn
Xin Mượn code anh quanghai 1 tí, em không hiểu tại sao chỗ kết nối em có bôi màu đỏ , em thấy đúng hết các tham số, mà sao có máy chạy được, có máy lại báo lỗi chỗ đó, do hôm nay khách hàng có yêu cầu dạng như vậy em lấy bí kíp ra dợt vài đường tất cả các file điều bị lỗi như vậy nhưng qua 3 máy khác thì ok, em lên diễn đàn thử file của anh cũng bị trình trạng như vậy, xin hỏi anh có phải là do office của em cài thiếu cái gì không? cảm ơn anh nhiều
Hinh minh họa
View attachment 138256

Đoán có thể là tên file bị sai phần mở rộng

 

[phihndhsp]

không phải sai phần đó đâu anh. Không hiểu thiếu chức năng gì đó trong máy tính, vì nó vẫn chạy bình thường ở máy khác mà, tất cả các file dạng như vậy chạy máy của em điều bị lỗi, nhưng qua máy khác thì ok, em muốn biết nguyên nhân để còn xử lý sau này