Tách số liệu theo điều kiện

[viendo]

Do tự ghi macro và sửa chạy theo nhu cầu tách số liệu hàng tháng, hiện cũng chạy được tuy nhiên do số liệu xử lý khoảng 25.000 dòng với code tự làm chạy rất lâu. Nay nhờ các Anh Chị giúp viết giúp code nhằm rút ngắn thời gian xử lý.
Code tự làm :

Sub TachSL()
Sheets("Tach").Select
If Range("a1") = "DaTach" Then Exit Sub
Range("a3").Select
Do While ActiveCell <> ""
    ActiveCell.Offset(0, 23).Range("A1").Select
        If ActiveCell = "ÑEÂM" And ActiveCell.Offset(0, -1) = "Thöôøng" Then
    ActiveCell.Offset(1, -23).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(-1, 0).Range("A1:af1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 12).Value = 2 * ActiveCell.Offset(-1, 12).Value / 3
    ActiveCell.Offset(0, 23).Value = "NGAØY"
    ActiveCell.Offset(0, 12).Value = 1.5 * ActiveCell.Offset(0, 12).Value / 3
    ActiveCell.Offset(1, 0).Select
        ElseIf ActiveCell = "ÑEÂM" And ActiveCell.Offset(0, -1) = "ChuNhat" Then
    ActiveCell.Offset(1, -23).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(-1, 0).Range("A1:af1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 12).Value = 2 * ActiveCell.Offset(-1, 12).Value / 3
    ActiveCell.Offset(0, 23).Value = "NGAØY"
    ActiveCell.Offset(0, 12).Value = ActiveCell.Offset(0, 12).Value / 3
    ActiveCell.Offset(1, 0).Select
        ElseIf ActiveCell = "NGAØY" And ActiveCell.Offset(0, -1) = "Thöôøng" Then
   ActiveCell.Offset(1, -23).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(-1, 0).Range("A1:af1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 12).Value = 2 * ActiveCell.Offset(-1, 12).Value / 3
    ActiveCell.Offset(0, 12).Value = 1.5 * ActiveCell.Offset(0, 12).Value / 3
    ActiveCell.Offset(1, 0).Select
        ElseIf ActiveCell = "NGAØY" And ActiveCell.Offset(0, -1) = "ChuNhat" Then
    ActiveCell.Offset(1, -23).Select
    End If
Loop
Range("a1").Value = "DaTach"
End Sub

Gửi kèm file có yêu cầu tách số liệu và vài dòng dữ liệu để test.
Cám ơn các Anh Chị.

 

[concogia]

Do tự ghi macro và sửa chạy theo nhu cầu tách số liệu hàng tháng, hiện cũng chạy được tuy nhiên do số liệu xử lý khoảng 25.000 dòng với code tự làm chạy rất lâu. Nay nhờ các Anh Chị giúp viết giúp code nhằm rút ngắn thời gian xử lý.
Code tự làm :

Sub TachSL()
Sheets("Tach").Select
If Range("a1") = "DaTach" Then Exit Sub
Range("a3").Select
Do While ActiveCell <> ""
    ActiveCell.Offset(0, 23).Range("A1").Select
        If ActiveCell = "ÑEÂM" And ActiveCell.Offset(0, -1) = "Thöôøng" Then
    ActiveCell.Offset(1, -23).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(-1, 0).Range("A1:af1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 12).Value = 2 * ActiveCell.Offset(-1, 12).Value / 3
    ActiveCell.Offset(0, 23).Value = "NGAØY"
    ActiveCell.Offset(0, 12).Value = 1.5 * ActiveCell.Offset(0, 12).Value / 3
    ActiveCell.Offset(1, 0).Select
        ElseIf ActiveCell = "ÑEÂM" And ActiveCell.Offset(0, -1) = "ChuNhat" Then
    ActiveCell.Offset(1, -23).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(-1, 0).Range("A1:af1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 12).Value = 2 * ActiveCell.Offset(-1, 12).Value / 3
    ActiveCell.Offset(0, 23).Value = "NGAØY"
    ActiveCell.Offset(0, 12).Value = ActiveCell.Offset(0, 12).Value / 3
    ActiveCell.Offset(1, 0).Select
        ElseIf ActiveCell = "NGAØY" And ActiveCell.Offset(0, -1) = "Thöôøng" Then
   ActiveCell.Offset(1, -23).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(-1, 0).Range("A1:af1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(-1, 12).Value = 2 * ActiveCell.Offset(-1, 12).Value / 3
    ActiveCell.Offset(0, 12).Value = 1.5 * ActiveCell.Offset(0, 12).Value / 3
    ActiveCell.Offset(1, 0).Select
        ElseIf ActiveCell = "NGAØY" And ActiveCell.Offset(0, -1) = "ChuNhat" Then
    ActiveCell.Offset(1, -23).Select
    End If
Loop
Range("a1").Value = "DaTach"
End Sub

Gửi kèm file có yêu cầu tách số liệu và vài dòng dữ liệu để test.
Cám ơn các Anh Chị.

Bạn thử chạy code này xem ( chưa hiểu đề lắm)

Public Sub TachNgoWa1()
    Dim Vung, Mg(), I, J, M, K
    Vung = Sheets("Tach").Range(Sheets("Tach").[A3], Sheets("Tach").[A50000].End(xlUp)).Resize(, 32).Value
    ReDim Mg(1 To UBound(Vung) * 2, 1 To 32)
        For I = 1 To UBound(Vung)
            K = K + 1
                For J = 1 To 32
                    Mg(K, J) = Vung(I, J)
                Next J
                If Vung(I, 23) & Vung(I, 24) <> "CHUNHATNGAY" Then
                    K = K + 1
                        For J = 1 To 32
                            Mg(K, J) = Vung(I, J)
                        Next J
                            If Vung(I, 23) = "THUONG" And Vung(I, 24) = "DEM" Then
                                Mg(K, 13) = Vung(I, 13) / 2: Mg(K, 24) = "NGAY"
                                Mg(K - 1, 13) = (Vung(I, 13) * 2) / 3
                            ElseIf Vung(I, 23) = "CHUNHAT" And Vung(I, 24) = "DEM" Then
                                Mg(K, 13) = Vung(I, 13) / 3: Mg(K, 24) = "NGAY"
                                Mg(K - 1, 13) = (Vung(I, 13) * 2) / 3
                            ElseIf Vung(I, 23) = "THUONG" And Vung(I, 24) = "NGAY" Then
                                Mg(K, 13) = Vung(I, 13) / 2
                                Mg(K - 1, 13) = (Vung(I, 13) * 2) / 3
                            End If
                End If
       Next I
    With Sheets("kQ")
        .[A3:AF50000].ClearContents
        .[A3].Resize(K, 32) = Mg
    End With
        Sheets("Kq").Select
End Sub

Bấm cái nút của bạn, kết qủa ở sheet Kq, mình giữ lại dữ liệu gốc
Mấy cái Chunhat, Ngày....viết không dấu cho gọn code
Thân