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

[kool1807]

Xin chào các bạn!
Các bạn giúp mình giải quyết một số vấn đề sau nhé. Hiện tại mình đang làm công việc quản lý bệnh nhân tại 1 bệnh viện trong đó có khám bệnh ngoại trú và nội trú. Trong 2 bảng dữ liệu của mình thì mỗi 1 bệnh nhân chỉ có 1 mã thẻ và bệnh nhân đó có thể đi khám nhiều lần trong 1 tháng. Câu hỏi như sau:
1. Mình muốn lọc ra danh sách những người bệnh nào đang nằm trong thời gian điều trị nội trú (file nội trú) mà đi khám ngoại trú (file ngoại trú) trong thời gian nằm viện, nếu có thì đưa ra danh sách. Danh sách đó thể hiện dưới dạng khám ngoại rồi đến khám nội, để nhìn cho dễ biết và so sánh.
2. Mình muốn lọc ra danh sách những người bệnh nào đang nằm trong thời gian điều trị nội trú mà lại xuất hiện người bệnh đó cũng trong khoảng thời gian điều trị nội trú đó. Ví dụ: bệnh nhân có mã thẻ DN4921234567890 đang nằm điều trị bệnh từ ngày 01/01/2015 đến 20/012015, nhưng trong danh sách nội trú lại xuất hiện bệnh nhân có mã thẻ DN4921234567890 nằm điều trị từ ngày 01/01/2015 đến 03/01/2015 hoặc nằm điều trị từ 01/01/2015 đến 20/01/2015 hoặc nằm điều trị từ 15/01/2015 đến 25/01/2015 thì xuất ra danh sách những bệnh nhân đó.
Mong được sự giúp đỡ của các bạn trong diễn đàn. Xin chân thành cám ơn! Mình xin đính kèm 2 file dữ liệu

 

[huyhoang1768]

Dùng pivottable nha mình làm mẫu ở sheet 1, ko hiểu pivottable thì lên google nha

 

[misibi]

Dùng pivottable nha mình làm mẫu ở sheet 1, ko hiểu pivottable thì lên google nha

Bạn ơi, Bạn có thể hướng dẫn rõ cho mình được không và có cách nào chỉ hiển thị ra danh sách mình cần ko, mà ko sử dụng pivot. Xin cám ơn

 

[Hau151978]

Theo mình nghĩ cái này nên sử dụng VBA vì có nhiều trường hợp cần xét: trùng nội - ngoại, nội - nội, ngoại - ngoại. Tạo 1 file chứa macro, tìm kiếm các thông tin trùng rồi lưu lại. Công thức sẽ rất chậm. Không biết pivot có đáp ứng được không, nếu có cũng khó.
Theo mình, nếu dùng VBA thì có thể làm như sau:
- Bổ sung cột LOAIKCB để phân biệt Nội trú (NT) hay Ngoại trú (NgT) và cột STT;
- Copy 2 sheet NT và NgT vào 1 sheet;
- Sort theo các tiêu chí: Mã thẻ, Ngày vào, Ngày ra;
- Đưa vào mảng, dùng vòng lặp duyệt từ trên xuống, so sánh với dòng trên: nếu trùng mã thẻ và ngày ra của hàng trên >= ngày vào của hàng dưới thì ghi cả 2 vào mảng kết quả.
Chắc là làm được mà mệt quá, bạn nào giúp với, mình cũng đang cần cái này.

 

[misibi]

Dùng pivottable nha mình làm mẫu ở sheet 1, ko hiểu pivottable thì lên google nha

Nếu sử dụng pivot nó sẽ lọc luôn ra những trường hợp những bệnh nhân có mã thẻ trùng. Nếu như vậy vẫn ko đúng với yêu cầu của bạn misibi. Cần xem xét lại. Giải pháp bạn huyhoang1768 ko được rồi

 

[Hau151978]

Bài này hoàn toàn có thể dùng hàm để kiểm tra xem được.
1. Lọc duy nhất 3 cột của sheet Ngoại-Nội . 3 cột đó là Mã thẻ, ngày vào, ngày ra
2. Dùng hàm countifs đếm xem Sheet Ngoại so với Sheet Nội (và ngược lại )như nào? nếu countifs ra => 1 thì là có trùng (counifs với 3 điều kiện là mã, >= ngày vào, <= ngày ra)
3. Như vậy có kết quả thì biết cái nào có bên Nội vừa có Bên ngoại trong thời gian đó, và ngược lại.

Khi tìm được lại phải ghi cặp trùng đó ra để xem trùng bao nhiêu ngày để còn xuất toán chứ. Nếu dùng công thức phải nhiều bước, dùng thêm cả cột phụ. DÙng VBA thì chỉ lập macro 1 lần, khi sử dụng thì kiểm tra dữ liệu đầu vào xem chuẩn chưa rồi chạy macro để xuất ra kết quả.

 

[misibi]

Có ai biết vba thì giúp dùm đi. Mình cũng đang cần cái này lắm

 

[be_09]

kool1807

Góp ý cho bạn như sau:

- Để đơn giản hóa vấn đề tìm thì nên gộp File NOI TRU VÀ NGOAI TRÚ vào 1 (vì có cùng cấu trúc, nên tôi nghĩ ngay là 2 File này được xuất từ phần mềm ra), thêm cột cuối có tên là Điều trị (để phân biệt nội trú, ngoại trú), và nên thêm 1 cột số thứ tự để lọc xong thi tra lại số liệu ở sheet gốc (theo dõi) là ở dòng nào để khi thêm hoặc sửa cho chính xác.

- Tiếp theo là sử dụng Advanced Filter để trích lọc mã thẻ là có kết quả như bạn yêu cầu ở bài #1.

 

[kool1807]

Góp ý cho bạn như sau:

- Để đơn giản hóa vấn đề tìm thì nên gộp File NOI TRU VÀ NGOAI TRÚ vào 1 (vì có cùng cấu trúc, nên tôi nghĩ ngay là 2 File này được xuất từ phần mềm ra), thêm cột cuối có tên là Điều trị (để phân biệt nội trú, ngoại trú), và nên thêm 1 cột số thứ tự để lọc xong thi tra lại số liệu ở sheet gốc (theo dõi) là ở dòng nào để khi thêm hoặc sửa cho chính xác.

- Tiếp theo là sử dụng Advanced Filter để trích lọc mã thẻ là có kết quả như bạn yêu cầu ở bài #1.

Bạn có thể hướng dẫn cụ thể hơn được ko be09

 

[be_09]

Bạn có thể hướng dẫn cụ thể hơn được ko be09

Nếu bạn thấy hướng đề xuất tại bài #10 là hợp lý thì tối làm thử để bạn tham khảo.

 

[kool1807]

Nếu bạn thấy hướng đề xuất tại bài #10 là hợp lý thì tối làm thử để bạn tham khảo.

Bạn làm thử và hướng dẫn cụ thể giúp mình nhé. Cám ơn

 

[be_09]

Bạn làm thử và hướng dẫn cụ thể giúp mình nhé. Cám ơn

File làm thử, về nội dung như góp ý ở bài 10 (File nội, ngoại trú dồn vào 1), nhưng mỗi File tôi chỉ đưa vào 10 dòng để thử nghiệm.

- Ở sheet Loc_DuLieu: Bạn gõ mã số rồi nhấn nút Lọc dữ liệu.

Khi làm xong File thì tôi góp ý thêm:
- Đúng ra phần theo dõi nên có cột số sổ, vì số sổ ít số hơn mã thẻ thì nhập liệu đở sai sót hơn, thứ 2 gõ số sổ có ít số thì gõ tìm sẽ nhanh hơn (khi khám sẽ đem sổ theo sẽ dễ kiểm tra hơn).

 

[kool1807]

File làm thử, về nội dung như góp ý ở bài 10 (File nội, ngoại trú dồn vào 1), nhưng mỗi File tôi chỉ đưa vào 10 dòng để thử nghiệm.

- Ở sheet Loc_DuLieu: Bạn gõ mã số rồi nhấn nút Lọc dữ liệu.

Khi làm xong File thì tôi góp ý thêm:
- Đúng ra phần theo dõi nên có cột số sổ, vì số sổ ít số hơn mã thẻ thì nhập liệu đở sai sót hơn, thứ 2 gõ số sổ có ít số thì gõ tìm sẽ nhanh hơn (khi khám sẽ đem sổ theo sẽ dễ kiểm tra hơn).

Xin cám ơn bạn!
Nhưng cái này là hình thức gõ từng mã thẻ một, dữ liệu liệu của mình mình có khi lên đến 10000 lượt, nếu như vậy thì mình phải nhập từng mã thẻ vào thì bất tiện lắm. Bạn có cách nào lọc một lần ra hết tất cả danh sách trùng nội trú với nội trú và trùng ngoại trú với ngoại trú không. Bạn giúp mình nhé. Cám ơn.

 

[be_09]

Xin cám ơn bạn!
Nhưng cái này là hình thức gõ từng mã thẻ một, dữ liệu liệu của mình mình có khi lên đến 10000 lượt, nếu như vậy thì mình phải nhập từng mã thẻ vào thì bất tiện lắm. Bạn có cách nào lọc một lần ra hết tất cả danh sách trùng nội trú với nội trú và trùng ngoại trú với ngoại trú không. Bạn giúp mình nhé. Cám ơn.

Không lẽ bạn vào sổ cùng lúc 10000 người, theo tôi suy luận thì khi có người đến khám thì họ xuất trình thẻ hoặc sổ, mình căn cứ vào số của nó để tìm và kiểm tra xem, trước đây họ khám nội trú, bây giờ đã thuyên giảm thì khám ngoại trú hoặc tái khám.

Đúng ra nội dung tại bài 1 bạn cần nêu cụ thể vấn đề, thì các thành viên khác sẽ có giải pháp nhanh chóng cho bạn hơn, vì không rỏ nên cứ cù nhầy mà công việc và kết quả chẳng giải quyết được đến đâu.

 

[Hau151978]

Không lẽ bạn vào sổ cùng lúc 10000 người, theo tôi suy luận thì khi có người đến khám thì họ xuất trình thẻ hoặc sổ, mình căn cứ vào số của nó để tìm và kiểm tra xem, trước đây họ khám nội trú, bây giờ đã thuyên giảm thì khám ngoại trú hoặc tái khám.

Đúng ra nội dung tại bài 1 bạn cần nêu cụ thể vấn đề, thì các thành viên khác sẽ có giải pháp nhanh chóng cho bạn hơn, vì không rỏ nên cứ cù nhầy mà công việc và kết quả chẳng giải quyết được đến đâu.

Đây là công việc của giám định BHYT anh à. Bệnh viện họ chuyển dữ liệu của bệnh nhân đi khám chữa bệnh, số tiền chi phí về BHXH. Giám định viên sẽ tìm dữ liệu trùng để loại ra.

 

[be_09]

Đây là công việc của giám định BHYT anh à. Bệnh viện họ chuyển dữ liệu của bệnh nhân đi khám chữa bệnh, số tiền chi phí về BHXH. Giám định viên sẽ tìm dữ liệu trùng để loại ra.

[h=2]Do tiêu đề chưa rỏ lắm: Tìm Dữ Liệu Trùng Của Bệnh Nhân Khi Đi Khám Bệnh[/h]
Vì vậy khi đọc tiêu đề tôi nghĩ cần lọc dữ liệu của bệnh nhân đã đi khám chữa bệnh ở những lần trước đó.

Sau khi đọc kỹ lại bài #1 thì đã phần nào hiểu được tác giả cần lọc ra danh sách của những bệnh nhân khám từ 2 lần trở lên trong 2 danh sách, cũng do tác giả giải thích thì nhiều nhưng đọc sơ qua thì không thể hiểu hết, nên có sự nhầm lẫn về cách giải quyết vấn đề.

Cái này tôi sẽ rút kinh nghiệm để khi tham gia giúp cho các thành viên khác được chính xác hơn.

 

[Hau151978]

- Theo file dữ liệu đầu bài, bạn copy các cột mã thẻ, ngày vào, ngày ra của file ngoại trú vào file BHYT.xlsm đính kèm. Bổ sung cột loại khám chữa bệnh là ngoại, đánh số thứ tự. Làm tương tự với file nội trú, copy vào sheet1 file BHYT.xlsm xuống dưới ngoại trú, đánh STT từ 1, thêm loại KCB là nội.
- Sort theo các tiêu chí: mã thẻ, ngày vào, ngày ra.
- Bấm Alt-F8, Enter. Dữ liệu trùng sẽ ghi vào sheet2.
Trong file đính kèm, mình đã làm các bước 1 và 2. Hai bước này cũng có thể dùng VBA cho tự động hóa nhưng mình buồn ngủ quá không làm được.

 

[kool1807]

- Theo file dữ liệu đầu bài, bạn copy các cột mã thẻ, ngày vào, ngày ra của file ngoại trú vào file BHYT.xlsm đính kèm. Bổ sung cột loại khám chữa bệnh là ngoại, đánh số thứ tự. Làm tương tự với file nội trú, copy vào sheet1 file BHYT.xlsm xuống dưới ngoại trú, đánh STT từ 1, thêm loại KCB là nội.
- Sort theo các tiêu chí: mã thẻ, ngày vào, ngày ra.
- Bấm Alt-F8, Enter. Dữ liệu trùng sẽ ghi vào sheet2.
Trong file đính kèm, mình đã làm các bước 1 và 2. Hai bước này cũng có thể dùng VBA cho tự động hóa nhưng mình buồn ngủ quá không làm được.

Bạn có thể cho nó thể tự động hóa buowcs1 và bước 2 như bạn nói được ko. Mình cám ơn bạn nhiều lắm.

 

[Hau151978]

Bạn có thể cho nó thể tự động hóa buowcs1 và bước 2 như bạn nói được ko. Mình cám ơn bạn nhiều lắm.

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

 

[kool1807]

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

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

 

[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