Nhờ viết code VBA cho vắng mặt hàng ngày (1 người xem)

kimthoa89 · 12/4/19

Nhờ anh chị giúp vba cho bảng vắng mặt hàng ngày theo điều kiện ah
em cảm ơn anh chị !

SA_DQ · 12/4/19

Bạn xài macro sự kiện này:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            MsgBox "Xong Rôi!", , "GPE.COM Xin Chào!"
        End With
    End If
End If
End Sub

kimthoa89 · 12/4/19

SA_DQ đã viết:

Bạn xài macro sự kiện này:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            MsgBox "Xong Rôi!", , "GPE.COM Xin Chào!"
        End With
    End If
End If
End Sub

Em cảm ơn ah, em đã làm được rùi ah
Nhưng cho em hỏi chút ah. Nếu em nhập sang sheet tong hợp bây h em muốn xóa dữ lieu đó thì phải làm sao ạ
Với lại em nhập stt khác thì stt ở trên vẫn chưa đc xóa bỏ ah

SA_DQ · 12/4/19

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Dg As Long             'X  '
 If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
 End If
 If Dg Then         'X  => '
    Rows(Dg & ":" & Dg).Delete
 End If                 '<=     X         '
 Exit Sub
GPE:    MsgBox "Xong Rôi!", , "GPE.COM Xin Chào!"
End Sub

kimthoa89 · 13/4/19

SA_DQ đã viết:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dg As Long             'X  '
If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
End If
If Dg Then         'X  => '
    Rows(Dg & ":" & Dg).Delete
End If                 '<=     X         '
Exit Sub
GPE:    MsgBox "Xong Rôi!", , "GPE.COM Xin Chào!"
End Sub

Em muốn xóa chữ xong rùi ah, mong anh chị giúp

NgoctrinhUSA · 13/4/19

kimthoa89 đã viết:
Em muốn xóa chữ xong rùi ah, mong anh chị giúp

Bạn bỏ dòng có chữ đó lác xong

kimthoa89 · 13/4/19

NgoctrinhUSA đã viết:
Bạn bỏ dòng có chữ đó lác xong

mình bỏ rùi nhưng chạy lại báo lỗi, vì mình chưa hiểu nhiều về mac

NgoctrinhUSA · 13/4/19

kimthoa89 đã viết:
mình bỏ rùi nhưng chạy lại báo lỗi, vì mình chưa hiểu nhiều về mac

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dg As Long 'X '
If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
Dim Rws As Long
On Error GoTo GPE
If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
Dg = Target.Row
With Sheet2
Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
.Cells(Rws, "C").Value = [I1].Value
Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
.Cells(Rws, "A").Value = Cells(Target.Row, "B").Value 'STT '
End With
End If
End If
If Dg Then 'X => '
Rows(Dg & ":" & Dg).Delete
End If '<= X '
Exit Sub

End Sub

LamNA · 13/4/19

kimthoa89 đã viết:
mình bỏ rùi nhưng chạy lại báo lỗi, vì mình chưa hiểu nhiều về mac

Bạn thử lại

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Dg As Long             'X  '
 If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
 End If
 If Dg Then         'X  => '
    Rows(Dg & ":" & Dg).Delete
 End If                 '<=     X         '
GPE:    Exit Sub
End Sub

kimthoa89 · 13/4/19

LamNA đã viết:

Bạn thử lại

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Dg As Long             'X  '
 If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
 End If
 If Dg Then         'X  => '
    Rows(Dg & ":" & Dg).Delete
 End If                 '<=     X         '
GPE:    Exit Sub
End Sub

Bị mất thông báo xong rồi, nhưng lại bị cắt bạn đó từ file data ah

LamNA · 13/4/19

kimthoa89 đã viết:
Bị mất thông báo xong rồi, nhưng lại bị cắt bạn đó từ file data ah

Thoa thử lại

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Dg As Long             'X  '
 If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
 End If
GPE:    Exit Sub
End Sub

kimthoa89 · 13/4/19

LamNA đã viết:

Thoa thử lại

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Dg As Long             'X  '
 If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
 End If
GPE:    Exit Sub
End Sub

Anh ơi, khi nhập lý do vào thì nó không nhảy ra khoảng trắng ah, mà lý do vẫn xuất hiện ở đó ah

LamNA · 13/4/19

kimthoa89 đã viết:
Anh ơi, khi nhập lý do vào thì nó không nhảy ra khoảng trắng ah, mà lý do vẫn xuất hiện ở đó ah

Là nhập xong xóa lý do đúng không?

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Dg As Long             'X  '
 If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
 End If
Range("I4:I1000").ClearContents
GPE:    Exit Sub

End Sub

kimthoa89 · 13/4/19

LamNA đã viết:

Là nhập xong xóa lý do đúng không?

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Dg As Long             'X  '
 If Not Intersect(Target, [I4].Resize([B3].CurrentRegion.Rows.Count)) Is Nothing Then
    Dim Rws As Long
    On Error GoTo GPE
    If Cells(Target.Row, "C").Value <> "" And Target.Value <> "" Then
        Dg = Target.Row
        With Sheet2
            Rws = .Cells(Cells.Rows.Count, "C").End(xlUp).Row + 1
            .Cells(Rws, "C").Value = [I1].Value
            Cells(Target.Row, "C").Resize(, 7).Copy Destination:=.Cells(Rws, "D")
            .Cells(Rws, "A").Value = Cells(Target.Row, "B").Value           'STT        '
        End With
    End If
 End If
Range("I4:I1000").ClearContents
GPE:    Exit Sub

End Sub

ok đúng rùi ah, em cảm ơn anh nhìu nhé

Nhờ viết code VBA cho vắng mặt hàng ngày (1 người xem)

Người dùng đang xem chủ đề này

kimthoa89

Thành viên thường trực

File đính kèm

SA_DQ

/(hông là gì!

kimthoa89

Thành viên thường trực

File đính kèm

SA_DQ

/(hông là gì!

kimthoa89

Thành viên thường trực

NgoctrinhUSA

Thành viên hoạt động

kimthoa89

Thành viên thường trực

NgoctrinhUSA

Thành viên hoạt động

LamNA

Thành viên tích cực

File đính kèm

kimthoa89

Thành viên thường trực

LamNA

Thành viên tích cực

File đính kèm

kimthoa89

Thành viên thường trực

LamNA

Thành viên tích cực

File đính kèm

kimthoa89

Thành viên thường trực

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian