Tìm Dữ Liệu Trùng Của Bệnh Nhân Khi Đi Khám Bệnh

[Hau151978]

Anh Hậu 151978 ơi. Em muốn thêm cột STT vào 2 file Ngoại trú và Nội trú thì mình sửa code lại như thế nào vậy anh. Anh chỉ em với

Trong file BHYT tự thêm STT rồi, không cần đâu. Có kết quả trùng thì đến dòng đó + 1 là thấy ngay.

 

[misibi]

Bạn copy file NOI TRU.xls, NGOAI TRU.xls vào cùng thư mục với BHYT.xlsm. Các cột phải giống như file mẫu bạn đã up. Bấm nút LỌc trùng là ra kết quả. KHông biết 10000 dòng thì tốc độ ra sao.

Function CopyData&(ByVal FileName$)
    Dim n&, m&, IsOpen As Boolean
    m = Sheet1.Range("A" & Columns(1).Rows.Count).End(xlUp).Row
    On Error Resume Next
    If Workbooks(FileName) Is Nothing Then
        Workbooks.Open ThisWorkbook.Path & "\" & FileName
    ElseIf Workbooks(FileName).Path <> ThisWorkbook.Path Then
        Workbooks(FileName).Close True
        Workbooks.Open ThisWorkbook.Path & "\" & FileName
    Else
        IsOpen = True
    End If
    ThisWorkbook.Activate
    Sheets(1).Activate
    With Workbooks(FileName).Sheets(1)
        n = .Range("A" & .Columns(1).Rows.Count).End(xlUp).Row
        .Range("E2:E" & n).Copy Range("B" & (m + 1))
        .Range("J2:K" & n).Copy Range("C" & (m + 1))
    End With
    If Not IsOpen Then Workbooks(FileName).Close False
    Range("A" & (m + 1)) = 1
    Range("A" & (m + 1)).AutoFill Range("A" & (m + 1), "A" & (m + n - 1)), xlFillSeries
    Range("E" & (m + 1)) = IIf(Left(FileName, 3) = "NOI", "NOI", "NGOAI")
    Range("E" & (m + 1)).AutoFill Range("E" & (m + 1), "E" & (m + n - 1)), xlFillCopy
    CopyData = m + n - 1
End Function
Sub LocTrung()
    Dim Arr(), KQ(), i&, j&, k&, m&, n&
    Sheet1.Activate
    n = Range("A" & Columns(1).Rows.Count).End(xlUp).Row - 1
    ReDim Arr(1 To n, 1 To 5)
    ReDim KQ(1 To n * 3, 1 To 5)
    Arr = Range("A2:E" & (n + 1)).Value
    i = 1
    Do While i <= n - 1
        j = i + 1
        Do While Arr(j, 2) = Arr(i, 2)
            If Arr(j, 3) > Arr(i, 4) Then Exit Do
            If j = i + 1 Then
                k = k + 1
                For m = 1 To 5
                    KQ(k, m) = Arr(i, m)
                Next
            End If
            k = k + 1
            For m = 1 To 5
                KQ(k, m) = Arr(j, m)
            Next
            j = j + 1
        Loop
        If KQ(k, 1) <> "" Then k = k + 1
        i = j
    Loop
    Sheet2.Activate
    Cells.Clear
    Range("A1:E" & k) = KQ
End Sub
Sub Main()
    Dim n&
    Application.ScreenUpdating = False
    CopyData "NOI TRU.xls"
    n = CopyData("NGOAI TRU.xls")
    Sheet1.Activate
    Range("A1:E" & n).Sort key1:=Range("B1"), key2:=Range("C1"), key3:=Range("D1"), Header:=xlYes
    LocTrung
    Sheet1.Range("A2:E" & n).ClearContents
    Application.ScreenUpdating = True
End Sub

Cám ơn bạn Hau151978, mình cũng đang cần cái này lắm, rất cám ơn bạn. Nhưng bạn cho mình hỏi. Có cách nào khi bấm vào lọc trùng thì kết quả xuất hiện bên sheet 2 nó sẽ xuất hiện tất cả các cột theo định dạng cột trong file nội trú hoặc ngoại trú không bạn. Xin chân thành cám ơn sự giúp đỡ nhiệt tình của bạn.

 

[kool1807]

Trong file BHYT tự thêm STT rồi, không cần đâu. Có kết quả trùng thì đến dòng đó + 1 là thấy ngay.

Anh Hau 151978 ơi. Sao khi nhận được file của anh về có điều chỉnh lại một chút để chạy theo ý muốn. Nhưng sao khi làm lại nó bị lỗi không lọc trùng được. Bên sheet1 chỉ copy được dữ liệu ngoại trú, còn nội trú thì ko copy được. Nên ko lọc trùng được. Anh xem và sửa giúp em với. Em cám ơn

 

[Hau151978]

Code sửa lại như sau (code của bài trước của mình sẽ lỗi khi 2 dòng đầu không trùng, cần thêm lệnh k=1 ở trước vòng lặp ngoài cùng).

Function CopyData&(ByVal FileName$)
    Dim n&, m&, IsOpen As Boolean
    m = Sheet1.Range("A" & Columns(1).Rows.Count).End(xlUp).Row
    On Error Resume Next
    If Workbooks(FileName) Is Nothing Then
        Workbooks.Open ThisWorkbook.Path & "\" & FileName
    ElseIf Workbooks(FileName).Path <> ThisWorkbook.Path Then
        Workbooks(FileName).Close True
        Workbooks.Open FileName
    Else
        IsOpen = True
    End If
    ThisWorkbook.Activate
    Sheets(1).Activate
    With Workbooks(FileName).Sheets(1)
        n = .Range("A" & .Columns(1).Rows.Count).End(xlUp).Row
        .Range("F2:F" & n).Copy Range("B" & (m + 1))
        .Range("K2:L" & n).Copy Range("C" & (m + 1))
        .Range("C2:C" & n).Copy Range("F" & (m + 1))
        .Range("D2:E" & n).Copy Range("G" & (m + 1))
        .Range("J2:J" & n).Copy Range("I" & (m + 1))
        .Range("O2:AX" & n).Copy Range("J" & (m + 1))
                
    End With
    If Not IsOpen Then Workbooks(FileName).Close False
    Range("A" & (m + 1)) = 1
    Range("A" & (m + 1)).AutoFill Range("A" & (m + 1), "A" & (m + n - 1)), xlFillSeries

'''''''''''''sua lenh nay    
    Range("E" & (m + 1)) = IIf(InStr(FileName, "80") > 0, "NOI", "NGOAI")
''''''''''''''''''''''''''''''''''''''''    

    Range("E" & (m + 1)).AutoFill Range("E" & (m + 1), "E" & (m + n - 1)), xlFillCopy
    CopyData = m + n - 1
End Function
Sub LocTrung()
    Dim Arr(), KQ(), i&, j&, k&, m&, n&
    Sheet1.Activate
    n = Range("A" & Columns(1).Rows.Count).End(xlUp).Row - 1
    ReDim Arr(1 To n, 1 To 45)
    ReDim KQ(1 To n * 3, 1 To 45)
    Arr = Range("A2:AS" & (n + 1)).Value
    i = 1

'''''''''''them lenh nay   
    k = 1
'''''''''''''''''''''
 
   Do While i <= n - 1
        j = i + 1
        Do While Arr(j, 2) = Arr(i, 2)
            If Arr(j, 3) > Arr(i, 4) Then Exit Do
            If j = i + 1 Then
                k = k + 1
                For m = 1 To 45
                    KQ(k, m) = Arr(i, m)
                Next
            End If
            k = k + 1
            For m = 1 To 45
                KQ(k, m) = Arr(j, m)
            Next
            j = j + 1
        Loop
        If KQ(k, 1) <> "" Then k = k + 1
        i = j
    Loop
    Sheet2.Activate
    Cells.Clear
    Range("A2:AS" & k) = KQ
End Sub
Sub Main()
    Dim n&
    Application.ScreenUpdating = False
    CopyData "Mau C80b-HD BENH VIEN.xls"
    n = CopyData("Mau C79b-HD BENH VIEN.xls")
    Sheet1.Activate
    Range("A1:AS" & n).Sort key1:=Range("B1"), key2:=Range("C1"), key3:=Range("D1"), Header:=xlYes
    LocTrung
    Sheet1.Range("A2:AS" & n).ClearContents
    Application.ScreenUpdating = True
End Sub

 

[misibi]

[QUOTE = Hau151978; 649.587]. Mã sửa lại như sau (mã of bài trước of mình sẽ lỗi khi 2 headers not match, cần thêm lệnh k = 1 out trước vòng lặp ngoài cùng)

Chức năng CopyData & (ByVal FileName $) 
    Dim n & m &, ISOpen As Boolean 
    m = Sheet1.Range ("A" & Columns (1) .Rows.Count) .End (xlUp) .Row 
    On Error Resume Next 
    Nếu Workbooks (FileName) là Không có gì đó 
        Workbooks. Mở ThisWorkbook.Path & "\" & Tên phim 
    ElseIf Workbooks (FileName) .Path <> ThisWorkbook.Path Sau đó 
        Workbooks (FileName) .Close Đúng 
        Workbooks.Open Tên phim 
    khác 
        ISOpen = True 
    End Nếu 
    ThisWorkbook.Activate 
    Sheets (1) .Activate 
    Với Workbooks (FileName) .Sheets (1) 
        n = .Range ("A" & .Columns (1) .Rows.Count) .End (xlUp) .Row 
        .Range ("F2: F" & n) .Copy Range ( "B" & (m + 1)) 
        .Range ("K2: L" & n) .Copy Range ("C" & (m + 1)) 
        .Range ("C2: C" & n) .Copy Range ( "F" & (m + 1)) 
        .Range ("D2: E" & n) .Copy Range ("G" & (m + 1)) 
        .Range ("J2: J" & n) .Copy Range ( "I" và (m + 1)) 
        .Range ("O2: AX" & n) .Copy Range ("J" & (m + 1))     End With     Nếu Không ISOpen Sau đó Workbooks (FileName) .Close False     Range ( "A" và (m + 1)) =     1. Range ("A" & (m + 1)) AutoFill Range ("A" & (m + 1), "A" và (m + n - 1)) , xlFillSeries '' '' '' '' '' '' 'sua lenh nay         Range ("E" & (m + 1)) = IIf (InStr (Tên phim "80")> 0, "Nội", "NGOẠI ") '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' '' ''         Range (" E "& (m + 1)) AutoFill Range ("E" & (m + 1), "E" & (m + n -. 1)), xlFillCopy     CopyData = m + n - 1 End Function Sub LocTrung ()     Dim Địa điểm đến (), KQ (), i &, j & k &, m &, n &     Sheet1.Activate     n = Range ("A" & Columns (1) .Rows.Count) .End (xlUp) .Row - 1     ReDim Địa điểm đến (1 To n, 1 Để 45)     ReDim KQ (1 đến n * 3, 1 đến 45)     Địa điểm đến = Range ("A2: AS" & (n + 1).) Giá trị     i = 1 '' '' '' '' '' 'chúng lenh nay        k = 1 '' '' '' '' '' '' '' '' '' ''    'Do Trong khi i <= n - 1         j = i + 1         Đỗ Trong khi Địa điểm đến (j, 2) = Địa điểm đến (i 2)             Nếu Địa điểm đến (j, 3)> Địa điểm đến (i, 4) Sau đó Exit Do             Nếu j = i + 1 Sau đó,                 k = k + 1                 Đối với m = 1 đến 45                     KQ (k, m) = Địa điểm đến (i, m )                 Tiếp theo             Cuối Nếu             k = k + 1             Đối với m = 1 đến 45                 KQ (k, m) = Địa điểm đến (j, m)             Tiếp             j = j + 1         Vòng         Nếu KQ (k, 1) <> "" Sau đó k = k + 1         i = j     Vòng     Sheet2.Activate     Cells.Clear     Range ("A2: AS" & k) = KQ End Sub Sub Main ()     Dim n &     Application.ScreenUpdating = False     CopyData "Mau C80b-HD bềnh VIEN.xls"     n = CopyData ("Mau C79b-HD bềnh VIEN.xls")     Sheet1.Activate     Range ("A1: AS" & n) .Sort Key1: = Range ("B1"), key2: = Range ("C1"), key3: = Range ("D1"), Header: = xlYes     LocTrung     Sheet1.Range ("A2: AS" & n) .ClearContents     Application.ScreenUpdating = True End Sub [/ code] [/ QUOTE]

Các bác ơi giúp em với, em đã chuyển đoạn code trên vào dữ liệu của em theo đúng yêu cầu của em rồi, sao vẫn không chạy được. Các bác xem giúp em với. Em xin chân thành cám ơn.

 

[kool1807]

Các anh chị ơi giúp em vấn đề này với, hiện tại em có chỉnh sửa code của lọc trùng này lại, do điều chỉnh thứ tự các cột Ngày vào và ngày ra thì bị báo lỗi, các anh chị hỗ trợ em sửa lỗi này lại nhé. Em xin chân thành cám ơn. Em xin đính kèm vào đường link bên dưới.
https://www.dropbox.com/s/5r2mihfbinexvsx/BHYT.rar?dl=0