Xin code chuyển dữ liệu

[Người Đưa Tin]

Trong tập tin đính kèm theo đây, gồm 3 sheet:
data - minhhoa - ketqua. Mình muốn chuyển danh sách văn bản trong sheet {data} vào sheet {ketqua} tương tự như sheet {minhhoa} và, sheet {ketqua} chỉ nhận kết quả theo thứ tự như sau:
TT - Số văn bản - Tên văn bản - Ngày ban hành - Ngày hiệu lực

Chân thành cám ơn.

 

[huuthang_bd]

Trong tập tin đính kèm theo đây, gồm 3 sheet:
data - minhhoa - ketqua. Mình muốn chuyển danh sách văn bản trong sheet {data} vào sheet {ketqua} tương tự như sheet {minhhoa} và, sheet {ketqua} chỉ nhận kết quả theo thứ tự như sau:
TT - Số văn bản - Tên văn bản - Ngày ban hành - Ngày hiệu lực

Chân thành cám ơn.

Bác dùng Code này thử nhé:

Sub GPE()
Application.ScreenUpdating = False
Dim StartCll As Range, FindCll As Range, EndCll As Range, i As Long
Sheets("ketqua").UsedRange.Offset(1).Clear
Set StartCll = Sheets("data").[A1]
Do Until Range(StartCll, Sheets("data").[A65536]).Find("SMS", StartCll, , 1, , 1) Is Nothing
    Set FindCll = Range(StartCll, Sheets("data").[A65536]).Find("SMS", StartCll, , 1, , 1)
    i = i + 1
    With Sheets("ketqua").Cells(i + 1, 1)
        .Value = Left(FindCll.Offset(-2).Value, InStr(FindCll.Offset(-2).Value, " ") - 1)
        .Offset(, 1).Value = Right(FindCll.Offset(-2).Value, Len(FindCll.Offset(-2).Value) - Len(.Value) - 1)
        .Offset(, 2).Value = FindCll.Offset(-1)
        .Offset(, 3).Value = Right(FindCll.Offset(5).Value, 4) & "/" & Mid(FindCll.Offset(5).Value, 4, 2) & "/" & Left(FindCll.Offset(5).Value, 2)
        If FindCll.Offset(7).Value Like "??/??/????" Then .Offset(, 4).Value = Right(FindCll.Offset(7).Value, 4) & "/" & Mid(FindCll.Offset(7).Value, 4, 2) & "/" & Left(FindCll.Offset(7).Value, 2)
    End With
    Set StartCll = FindCll.Offset(1)
Loop
Application.ScreenUpdating = True
End Sub

Lưu ý: Trước khi chạy Code trên file của mình, Bác nhớ sửa dữ liệu ở ô A1 sheet data lại cho đồng nhất với dữ liệu ở các ô khác. Chỉ để lại 1 03-TC/GTBĐ thôi.

 

[Người Đưa Tin]

Sau 1 đêm trằn trọc với lá phiếu đi bầu ngày 22/05/2011, chắc em phải mồi mấy điếu thuốc "Vàm Cỏ" cùng pha vài tách ca phê mới các bác dùng cho có hưng phấn để viết code hộ em cho bài toán này.

Nhìn dữ liệu trong sheet {data}, em nghiệm ra có 1 quy luật như sau:

Cứ 10 dòng dữ liệu (từ Row 1 đến row 10 là 1 dữ liệu), sang row 11 là dữ liệu mới

Row 1 - row 11 - row 21,....: thể hiện cột số thứ tự và số văn bản (Cứ cộng thêm 10 dòng)
Row 2 - row 12 - row 22,....: thể hiện tên văn bản
Row 8 - row 18 - row 28,....: thể hiện ngày phát hành văn bản
Row 10 - row 20 - row 30,....: thể hiện ngày hiệu lực văn bản

Dữ liệu văn bản này, em sưu tầm tổng hợp lại đa phần đề cập về hiệp định tránh đánh thuế hai lần. Xin cám ơn đã quan tâm, giúp đỡ.

 

[huuthang_bd]

Sau 1 đêm trằn trọc với lá phiếu đi bầu ngày 22/05/2011, chắc em phải mồi mấy điếu thuốc "Vàm Cỏ" cùng pha vài tách ca phê mới các bác dùng cho có hưng phấn để viết code hộ em cho bài toán này.

Nhìn dữ liệu trong sheet {data}, em nghiệm ra có 1 quy luật như sau:

Cứ 10 dòng dữ liệu (từ Row 1 đến row 10 là 1 dữ liệu), sang row 11 là dữ liệu mới

Row 1 - row 11 - row 21,....: thể hiện cột số thứ tự và số văn bản (Cứ cộng thêm 10 dòng)
Row 2 - row 12 - row 22,....: thể hiện tên văn bản
Row 8 - row 18 - row 28,....: thể hiện ngày phát hành văn bản
Row 10 - row 20 - row 30,....: thể hiện ngày hiệu lực văn bản

Dữ liệu văn bản này, em sưu tầm tổng hợp lại đa phần đề cập về hiệp định tránh đánh thuế hai lần. Xin cám ơn đã quan tâm, giúp đỡ.

Lúc đầu cháu cũng viết theo hướng này, dữ liệu theo quy luật như Bác nói. Nhưng mà khi chạy code mới biết không phải như vậy. Một số văn bản không có ngày áp dụng (ví dụ như: 28, 31, 32, 33,...) và dòng ngày áp dụng cũng không có luôn, các dòng khác được đẩy lên và quy luật này không còn tồn tại nữa.

 

[Người Đưa Tin]

Em chân thành cám ơn bác huuthang_bd đã nhanh chóng post bài hỗ trợ em.

Đã nhận xét đúng:

Trước khi chạy Code trên file của mình, Bác nhớ sửa dữ liệu ở ô A1 sheet data lại cho đồng nhất với dữ liệu ở các ô khác. Chỉ để lại 1 03-TC/GTBĐ thôi.

Thoạt đầu, sử dụng kết quả của bác, em thấy 1 số vùng vẫn chưa thể hiện dữ liệu ngày hiệu lực, cụ thể:

Tại số thứ tự: 27 69/TCT/HTQT Công văn 69/TCT/HTQT của Tổng cục Thuế về việc giấy chứng nhận cư trú và hợp pháp hoá lãnh sự đối với các văn bản liên quan đến thuế của Nga 4/1/2002 - Không có kết quả dữ liệu ngày hiệu lực

Tại số thứ tự: 30 1901/TCT/TTr Công văn 1901/TCT/TTr của Tổng cục Thuế về việc xác minh hàng hoá bán cho các doanh nghiệp nước ngoài 5/14/2002 - Không có kết quả dữ liệu ngày hiệu lực

Tại số thứ tự: 31 2806/TCT/HTQT Công văn 2806/TCT/HTQT của Tổng cục Thuế về việc trừ chi phí của chi nhánh nước ngoài 7/25/2002 - Không có kết quả dữ liệu ngày hiệu lực

Nhưng nhìn lại dữ liệu gốc thì các văn bản này không có dữ liệu ngày hiệu lực. Thực ra, ngày hiệu lực cho các văn bản này cũng là ngày ban hành của chính văn bản đó.

 

[Ba Tê]

Sau 1 đêm trằn trọc với lá phiếu đi bầu ngày 22/05/2011, chắc em phải mồi mấy điếu thuốc "Vàm Cỏ" cùng pha vài tách ca phê mới các bác dùng cho có hưng phấn để viết code hộ em cho bài toán này.

Nhìn dữ liệu trong sheet {data}, em nghiệm ra có 1 quy luật như sau:

Cứ 10 dòng dữ liệu (từ Row 1 đến row 10 là 1 dữ liệu), sang row 11 là dữ liệu mới

Row 1 - row 11 - row 21,....: thể hiện cột số thứ tự và số văn bản (Cứ cộng thêm 10 dòng)
Row 2 - row 12 - row 22,....: thể hiện tên văn bản
Row 8 - row 18 - row 28,....: thể hiện ngày phát hành văn bản
Row 10 - row 20 - row 30,....: thể hiện ngày hiệu lực văn bản

Dữ liệu văn bản này, em sưu tầm tổng hợp lại đa phần đề cập về hiệp định tránh đánh thuế hai lần. Xin cám ơn đã quan tâm, giúp đỡ.

Hổng chắc vậy đâu Già Gân ơi, trong <Data> cũng có rất nhiều dữ liệu không phải 10 dòng đâu, ví dụ: dòng 270, 299, 308 ... chỉ có 9 dòng cho 1 dữ liệu thôi. Lọc theo qui luật của Già là "toi".

 

[huuthang_bd]

Nếu Bác muốn văn bản nào không có ngày hiệu lực thì lấy ngày ban hành làm ngày hiệu lực thì sửa Code lại thành như thế này:

Sub GPE()
Application.ScreenUpdating = False
Dim StartCll As Range, FindCll As Range, EndCll As Range, i As Long
Sheets("ketqua").UsedRange.Offset(1).Clear
Set StartCll = Sheets("data").[A1]
Do Until Range(StartCll, Sheets("data").[A65536]).Find("SMS", StartCll, , 1, , 1) Is Nothing
    Set FindCll = Range(StartCll, Sheets("data").[A65536]).Find("SMS", StartCll, , 1, , 1)
    i = i + 1
    With Sheets("ketqua").Cells(i + 1, 1)
        .Value = Left(FindCll.Offset(-2).Value, InStr(FindCll.Offset(-2).Value, " ") - 1)
        .Offset(, 1).Value = Right(FindCll.Offset(-2).Value, Len(FindCll.Offset(-2).Value) - Len(.Value) - 1)
        .Offset(, 2).Value = FindCll.Offset(-1)
        .Offset(, 3).Value = Right(FindCll.Offset(5).Value, 4) & "/" & Mid(FindCll.Offset(5).Value, 4, 2) & "/" & Left(FindCll.Offset(5).Value, 2)
        If FindCll.Offset(7).Value Like "??/??/????" Then
            .Offset(, 4).Value = Right(FindCll.Offset(7).Value, 4) & "/" & Mid(FindCll.Offset(7).Value, 4, 2) & "/" & Left(FindCll.Offset(7).Value, 2)
        Else
            .Offset(, 4).Value = .Offset(, 3).Value
        End If
    End With
    Set StartCll = FindCll.Offset(1)
Loop
Application.ScreenUpdating = True
End Sub

Em chân thành cám ơn bác huuthang_bd đã nhanh chóng post bài hỗ trợ em.

Hix... Xưng hô thế này tổn thọ con Bác ơi...

 

[Người Đưa Tin]

Tương tự bài toán trên, em có dữ liệu khác và muốn thể hiện kết quả như sau:


TT - Ngay ban hành - Cơ quan ban hành - Nội dung
01 - 19/05/2011 - CHÍNH PHỦ - Nghị quyết 80/NQ-CP về định hướng giảm nghèo bền vững thời kỳ từ năm 2011 đến năm 2020.

Chú ý: Cứ qua mỗi nhóm cơ quan ban hành, số thứ tự được đánh lại từ 1 tăng dần.

Xin cám ơn.

 

[huuthang_bd]

Tương tự bài toán trên, em có dữ liệu khác và muốn thể hiện kết quả như sau:


TT - Ngay ban hành - Cơ quan ban hành - Nội dung
01 - 19/05/2011 - CHÍNH PHỦ - Nghị quyết 80/NQ-CP về định hướng giảm nghèo bền vững thời kỳ từ năm 2011 đến năm 2020.

Chú ý: Cứ qua mỗi nhóm cơ quan ban hành, số thứ tự được đánh lại từ 1 tăng dần.

Xin cám ơn.

Sao cái này Bác không lấy số hiệu văn bản nhỉ.

Sub GPE()
Application.ScreenUpdating = False
Dim Obj As Variant, Findstr, Cll As Range, CoQuan As Range, STT As Long
Sheets("ketqua").UsedRange.Offset(1).ClearContents
Set Obj = CreateObject("VBScript.RegExp")
Obj.Pattern = "\d\d/\d\d/\d\d\d\d"
For Each Cll In Sheets("dulieu01").[A:A].SpecialCells(2, 23)
    If Left(Cll.Value, 1) <> "*" Then
        Set CoQuan = Cll
        STT = 0
        GoTo NextCll
    End If
    Set Findstr = Obj.Execute(Cll.Value)
        STT = STT + 1
        With Sheets("ketqua").[A65536].End(xlUp).Offset(1)
            .Value = STT
            .Offset(, 1).Value = Right(Findstr(0).Value, 4) & "/" & Mid(Findstr(0).Value, 4, 2) & "/" & Left(Findstr(0).Value, 2)
            .Offset(, 2).Value = CoQuan.Value
            .Offset(, 3).Value = Right(Cll.Value, Len(Cll.Value) - InStr(Cll.Value, "ban hành ") - 8)
        End With
NextCll:
Next
Application.ScreenUpdating = True
End Sub

 

[sealand]

Dựa vào ý tưởng của Huu Thang mình chuyển dùng mảng cho nhanh.
Kết qua ở Minh hoa, cứ mở sheet là Reset muc luc

 

[Người Đưa Tin]

Sao cái này Bác không lấy số hiệu văn bản nhỉ.

Bài viết của em thiếu trích số hiệu văn bản rùi, xin cám ơn đã phát hiện thông tin cần thiết. Xin giúp bổ sung đoạn code này luôn thể. Xin đa tạ.
Một lần nữa xin cám ơn tất cả đã quan tâm.
Vậy là em có công cụ này để em upload văn bản lên cho các bác tham khảo nhanh rồi.

 

[Người Đưa Tin]

Các bài viết của các Thầy huuthang_bd, sealand rất hữu ích, nếu có thời gian xin vui lòng chú thích ý nghĩa từng câu lệnh để em có dịp phát huy bài toán này.
Xin cám ơn.
Mong rằng yêu cầu này không làm phật lòng các vị sư phụ ạ.

 

[huuthang_bd]

Bài viết của em thiếu trích số hiệu văn bản rùi, xin cám ơn đã phát hiện thông tin cần thiết. Xin giúp bổ sung đoạn code này luôn thể. Xin đa tạ.
Một lần nữa xin cám ơn tất cả đã quan tâm.
Vậy là em có công cụ này để em upload văn bản lên cho các bác tham khảo nhanh rồi.

Vậy thì Bác sửa code lại như thế này:

Sub GPE()
'Bắt đầu
Application.ScreenUpdating = False
'Tắt chế độ tự động Update
Dim Obj As Variant, Findstr, Cll As Range, CoQuan As Range, STT As Long
'Khai báo các biến
On Error Resume Next
'Bẫy lỗi: Nếu gặp lỗi thì bỏ qua và tiếp tục thực thi các lệnh tiếp theo
Sheets("ketqua").UsedRange.Offset(1).ClearContents
'Xóa vùng kết quả cũ
Set Obj = CreateObject("VBScript.RegExp")
'Gán Obj bằng đối tượng VBScript.RegExp, đây là một đối tượng về tìm kiếm và thay thế chuỗi
Obj.Pattern = "\d\d/\d\d/\d\d\d\d"
'Thiết lập chuỗi tìm kiếm dạng "??/??/????" với mỗi dấu "?" là một chữ số
For Each Cll In Sheets("dulieu01").[A:A].SpecialCells(2, 23)
'Duyệt qua các ô có dữ liệu trong cột A của sheet dulieu01
    If Left(Cll.Value, 1) <> "*" Then
    'Nếu ký tự đầu tiên của ô không phải là ký tự "*" thì
        Set CoQuan = Cll
        'Gán ô đó vào biến CoQuan
        STT = 0
        'Gán biến STT bằng 0 để thực hiện đánh số thứ tự lại từ đầu
        GoTo NextCll
        'Nhảy đến nhãn NextCll (để duyệt ô tiếp theo)
    End If
    'Kết thúc cấu trúc If
    Set Findstr = Obj.Execute(Cll.Value)
    'Gán mảng các chuỗi tìm được trong ô vào biến Findstr (các chuỗi này sẽ có dạng ??/??/???? do đã khai báo Pattern ở trên
        STT = STT + 1
        'Cho STT tăng 1 đơn vị
        With Sheets("ketqua").[A65536].End(xlUp).Offset(1)
        'Với ô dưới ô cuối cùng có dữ liệu trong cột A sheet ketqua
            .Value = STT
            'Gán cho nó giá trị của biến STT
            .Offset(, 1).Value = Mid(Cll.Value, 9, Findstr(0).FirstIndex - 17)
            'Gán cho ô cách nó 0 dòng, 1 cột giá trị bằng chuỗi được lấy từ ô đang xét (Cll) với: 9 là độ dài của chuỗi "* (SMS: "; Findstr(0).FirstIndex là vị trí tìm được chuỗi ??/??/????; 17 là 9 cộng độ dài chuỗi ") - Ngày "
            .Offset(, 2).Value = Right(Findstr(0).Value, 4) & "/" & Mid(Findstr(0).Value, 4, 2) & "/" & Left(Findstr(0).Value, 2)
            'Gán cho ô cách nó 0 dòng, 2 cột giá trị bằng chuỗi tìm được (các hàm Right, Mid, Left dùng để đưa về dạng ngày tháng tránh trường hợp các máy định dạng mặc định khác nhau cho kết quả khác nhau)  
            .Offset(, 3).Value = CoQuan.Value
            'Gán cho ô cách nó 0 dòng, 3 cột giá trị bằng giá trị ô CoQuan
            .Offset(, 4).Value = Right(Cll.Value, Len(Cll.Value) - InStr(Cll.Value, "ban hành ") - 8)
            'Gán cho ô cách nó 0 dòng, 4 cột giá trị bằng chuỗi đằng sau chuỗi "ban hành " trong ô
        End With
        'Kết thúc cấu trúc With
NextCll:
'Nhãn NextCll
Next
'Kết thúc cấu trúc For
Application.ScreenUpdating = True
'Bật chế độ tự động Update
End Sub
'Kết thúc

 

[LinDan]

Quả là bài giải rất hay, giá như có tài liệu nào nói về "VBScript.RegExp" thì hay quá.