[Help] tạo macro xoá dòng có điều kiện trong excel (1 người xem)

[siena19]

Nhờ mọi người giúp đỡ.

Em cần xóa dòng trong excel như sau chỉ giữ lại các dong có dạng là at point x=... y=.... được lấy ra từ list cad và thay các dòng bị xóa bằng 1 dòng blank. Em cảm ơn mọi người


LWPOLYLINE Layer: "D-STR"
Space: Model space
Color: 4 (cyan) Linetype: "BYLAYER"
Handle = b1a20
Open
Constant width 0.0000
area 124163464.9649
length 42961.5182


at point X=6365.1700 Y=-28089.4343 Z= 0.0000
at point X=12797.8646 Y=-35506.8481 Z= 0.0000
at point X=18060.9783 Y=-32854.5607 Z= 0.0000
at point X=25663.2536 Y=-37170.1470 Z= 0.0000
at point X=33850.3195 Y=-37799.5033 Z= 0.0000
at point X=39203.4010 Y=-39597.6643 Z= 0.0000
at point X=42667.1593 Y=-36495.8367 Z= 0.0000


LWPOLYLINE Layer: "D-STR"
Space: Model space
Color: 4 (cyan) Linetype: "BYLAYER"
Handle = b1a1f
Open
Constant width 0.0000
area 85546404.4192
length 38085.1139


at point X=10098.3993 Y=-19536.9597 Z= 0.0000
at point X=13247.2706 Y=-24931.4426 Z= 0.0000
at point X=18645.3360 Y=-25650.7069 Z= 0.0000
at point X=22783.8527 Y=-23717.6838 Z= 0.0000
at point X=29441.4666 Y=-27224.0976 Z= 0.0000
at point X=33984.8385 Y=-27269.0518 Z= 0.0000
at point X=40732.4200 Y=-25965.3850 Z= 0.0000
at point X=43566.4043 Y=-26504.8333 Z= 0.0000

 

[haonlh]

Trong file excel cần xử lý, bạn chọn cả vùng cần xử lý, dùng lọc (kg biết bạn dùng E2003 hay E2007 nên kg nói chi tiết được)

Chú ý có 2 mục. Mục đầu chọn "Does not begin with" mục kia chọn "at"

Chọn vùng và gõ delete

 

[siena19]

em dùng e2010, anh nói rõ hơn đc không

 

[siena19]

Sheet 1 là dữ liệu đầu vào, sheet 2 là kết quả mong muốn. Ai giúp em với ạ. Em cảm ơn nhiều

 

[phulien1902]

Sheet 1 là dữ liệu đầu vào, sheet 2 là kết quả mong muốn. Ai giúp em với ạ. Em cảm ơn nhiều

BẠn tham khảo:

Sub abc()
    Sheet1.Range("a1:a" & Range("G" & Rows.Count).End(3).Row).AutoFilter 1, Range("I1")
    Sheet1.Range("A2:A" & Range("G" & Rows.Count).End(3).Row).SpecialCells(12).EntireRow.Copy Sheet2.Range("A1")
    ActiveSheet.AutoFilterMode = False
End Sub

Muộn quá rồi, có gì mai sửa tiếp.

 

[siena19]

BẠn tham khảo:

Sub abc()
    Sheet1.Range("a1:a" & Range("G" & Rows.Count).End(3).Row).AutoFilter 1, Range("I1")
    Sheet1.Range("A2:A" & Range("G" & Rows.Count).End(3).Row).SpecialCells(12).EntireRow.Copy Sheet2.Range("A1")
    ActiveSheet.AutoFilterMode = False
End Sub

Muộn quá rồi, có gì mai sửa tiếp.

Thím ơi, lên tiếp đi thím ơi. Cảm ơn thím nhiều.

 

[phulien1902]

Bạn thay Code cũ bằng Code mới này nhé:

Sub abc_New()
    Dim i&
    [I1] = "           at point*"
    [G1:G100] = 1
    Application.ScreenUpdating = False
    Sheet1.Range("a1:a" & Range("G" & Rows.Count).End(3).Row).AutoFilter 1, Range("I1")
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(i, 7).EntireRow.Hidden = True Then Cells(i, 7).EntireRow.Delete
    Next i
    Application.ScreenUpdating = True
    Rows("1:1").Delete: Columns(7).Delete
 End Sub

 

[siena19]

Bạn thay Code cũ bằng Code mới này nhé:

Sub abc_New()
    Dim i&
    [I1] = "           at point*"
    [G1:G100] = 1
    Application.ScreenUpdating = False
    Sheet1.Range("a1:a" & Range("G" & Rows.Count).End(3).Row).AutoFilter 1, Range("I1")
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(i, 7).EntireRow.Hidden = True Then Cells(i, 7).EntireRow.Delete
    Next i
    Application.ScreenUpdating = True
    Rows("1:1").Delete: Columns(7).Delete
 End Sub

Thím ơi, thím sửa cho em cái code sau khi xóa, tạo 1 dòng trắng ngăn cách cách như trong file dữ liệu được không. Em rất cảm ơn thím.

 

[phulien1902]

sửa cho em cái code sau khi xóa, tạo 1 dòng trắng ngăn cách cách như trong file dữ liệu được không.

Bạn dùng Code dưới đây nhé:

Sub abc_New2()
    Dim i&
    [I1] = "           at point*"
    [G1:G100] = 1
    Application.ScreenUpdating = False
    Sheet1.Range("a1:a" & Range("G" & Rows.Count).End(3).Row).AutoFilter 1, Range("I1")
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(i, 7).EntireRow.Hidden = True Then Cells(i, 7).EntireRow.Delete
    Next i
    Application.ScreenUpdating = True
    Rows("1:1").Delete
    With ActiveSheet
        For i = 1 To .Range("G65000").End(xlUp).Row Step 6
            If .Range("A" & i + 1) <> "" And .Range("A" & i) <> "" Then
                .Range("A" & i & ":A" & i).EntireRow.Insert
            End If
        Next i
    End With
    Columns(7).Delete
End Sub

 

[siena19]

Bạn dùng Code dưới đây nhé:

Sub abc_New2()
    Dim i&
    [I1] = "           at point*"
    [G1:G100] = 1
    Application.ScreenUpdating = False
    Sheet1.Range("a1:a" & Range("G" & Rows.Count).End(3).Row).AutoFilter 1, Range("I1")
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(i, 7).EntireRow.Hidden = True Then Cells(i, 7).EntireRow.Delete
    Next i
    Application.ScreenUpdating = True
    Rows("1:1").Delete
    With ActiveSheet
        For i = 1 To .Range("G65000").End(xlUp).Row Step 6
            If .Range("A" & i + 1) <> "" And .Range("A" & i) <> "" Then
                .Range("A" & i & ":A" & i).EntireRow.Insert
            End If
        Next i
    End With
    Columns(7).Delete
End Sub

Cảm ơn thím rất nhiều, dạ được rồi.

 

[siena19]

Anh @phulien1902 ơi, giúp em tạo kết quả qua 1 sheet mới được không ạ, phiền anh quá