3 tháng 4, 2012

Cach tìm kiếm dữ liệu khác nhau giữa 2 bảng excel

Làm thử = ADO như sau: 
(Mở file này so sánh file kia và ngược lại)
- Chép code sau vào module của 2 file

Code:
Sub GetWorksheetData(strSourceFile As String, strSQL As String, TargetCell As Range)
Dim cn As ADODB.Connection, rs As ADODB.Recordset, f As Integer, r As Long
    If TargetCell Is Nothing Then Exit Sub
    Set cn = New ADODB.Connection
    On Error Resume Next
        cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};DriverId=790;ReadOnly=True;" & _
                "DBQ=" & strSourceFile & ";"
    On Error GoTo 0
    If cn Is Nothing Then
        MsgBox "Can't find the file!", vbExclamation, ThisWorkbook.Name
        Exit Sub
    End If

    Set rs = New ADODB.Recordset
    On Error Resume Next
    
    rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
    On Error GoTo 0
    
    If rs Is Nothing Then
        MsgBox "Can't open the file!", vbExclamation, ThisWorkbook.Name
        cn.Close
        Set cn = Nothing
        Exit Sub
    End If

    TargetCell.CopyFromRecordset rs

    If rs.State = adStateOpen Then
        rs.Close
    End If
    
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    
End Sub
- Chép code sau vào module file "NhapTay"



Code:
Sub LookUpValue()
    Dim MyPath As String, FName As Variant, rng As Range
    MyPath = Application.DefaultFilePath
    FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*")

    If FName = False Then
        Exit Sub
    Else
    MyPath = FName
    Application.ScreenUpdating = False
        For Each rng In Range("C2:C" & Range("C60000").End(xlUp).Row)
          If Len(rng) > 0 Then
            With rng
              .Offset(, 3) = ""
              GetWorksheetData MyPath, "SELECT 'Da co' as SP FROM [Sheet1$] where MASP like '" & .Value & "';", .Offset(, 3)
              If Len(rng) > 0 And Len(rng.Offset(, 3)) = 0 Then rng.Offset(, 3) = "Chua co"
            End With
          End If
        Next
    Application.ScreenUpdating = True
    End If
    
End Sub
- Chép code sau vào module file "DuLieuTuChuongTrinh"

Code:
Sub LookUpValue()
    Dim MyPath As String, FName As Variant, rng As Range
    MyPath = Application.DefaultFilePath
    FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*")

    If FName = False Then
        Exit Sub
    Else
    MyPath = FName
    Application.ScreenUpdating = False
        For Each rng In Range("e2:e" & Range("E60000").End(xlUp).Row)
          If Len(rng) > 0 Then
            With rng
              .Offset(, 8) = ""
              GetWorksheetData MyPath, "SELECT 'Da co' as SP FROM [NhapTay$] where MASP like '" & .Value & "';", .Offset(, 8)
              If Len(rng) > 0 And Len(rng.Offset(, 8)) = 0 Then rng.Offset(, 8) = "Chua co"
            End With
          End If
        Next
    Application.ScreenUpdating = True
    End If
    
End Sub
* Với điều kiện phải đổi tên sheet, đặt tên cột lại (Tham khảo ví dụ mẫu), code như sau:

Bạn xem file nhé.
(Lưu ý nhớ giải nén rồi mở file nhé.)
Tập tin đính kèm Tập tin đính kèm

0 nhận xét:

|» Đăng hình ảnh | code chèn sẽ là [img] Link ảnh [/img]
|» Đăng nhạc của tui | code sẽ là [nct] Link bài hát [/nct]
|» Đăng Video Youtube | code sẽ là [youtube] Link Video Youtube [/youtube]
|» <b> Chữ in đậm <\/b>
|» <i> Chữ in nghiêng <\/i>

:) :( :)) :(( =)) Mã hóa code