Cần giúp về code xoá bỏ ô hiện có,và điền luôn những dòng chưa có (1 người xem)

[lamchanphieu]

Mình có gởi file excel có ghi nội dung , xin các anh chị vui lòng giúp đỡ !

 

[befaint]

Chép vào một module.

Sub ptm()
Dim z As Long, zz As Long, TF(), TK(), r As Long, n As Long, KQ(), T
With Sheet1
    n = .Rows.Count
    TF = .Range("F1:F" & .Range("F" & n).End(xlUp).Row)
    z = UBound(TF, 1)
    TK = .Range("K1:K" & .Range("K" & n).End(xlUp).Row)
    zz = UBound(TK, 1)
    ReDim KQ(1 To n, 0)
    For r = 1 To z
        If TF(r, 1) = "K" Then KQ(r, 0) = ""
    Next r
    For r = 1 To zz
        T = CLng(Replace(TK(r, 1), "A", ""))
        If IsNumeric(T) Then
            If T <= n Then
                If T > z Then KQ(T, 0) = "K"
                If T >= 1 And T <= z Then
                    If TF(T, 1) <> "K" Then KQ(T, 0) = "K"
                End If
            End If
        End If
    Next r
    n = Application.Max(z, T)
    .Range("D1").Resize(n, 1) = KQ
End With

 

[Ba Tê]

Mình có gởi file excel có ghi nội dung , xin các anh chị vui lòng giúp đỡ !

Bạn chạy thử Sub này coi sao:

Public Sub GPE()
Dim sArr(), dArr(), I As Long, R As Long
R = Range("K65536").End(xlUp).Row
sArr = Range("F1:F" & R).Value
ReDim dArr(1 To R, 1 To 1)
For I = 1 To R
    If sArr(I, 1) = Empty Then dArr(I, 1) = "K"
Next I
Range("F1").Resize(R) = dArr
End Sub

 

[HieuCD]

bạn dùng thử code sau, chạy cũng không chậm lắm

Sub GPE()
Dim i As Long
For i = 1 To Range("K1").End(xlDown).Row
  Cells(i, 6) = IIf(Cells(i, 6) = "K", "", "K")
Next i
End Sub

 

[lamchanphieu]

Bạn chạy thử Sub này coi sao:

Public Sub GPE()
Dim sArr(), dArr(), I As Long, R As Long
R = Range("K65536").End(xlUp).Row
sArr = Range("F1:F" & R).Value
ReDim dArr(1 To R, 1 To 1)
For I = 1 To R
    If sArr(I, 1) = Empty Then dArr(I, 1) = "K"
Next I
Range("F1").Resize(R) = dArr
End Sub

code này chạy đúng rồi bạn,xin cảm ơn nhé

 

[lamchanphieu]

xin cám ơn tất cả các anh chị nhé!