Lọc và Chuyển đổi Dữ liệu theo form. (1 người xem)

nguyenquyetnd993 · 13/2/20

Chào mọi người!,

Em có 1 file xuất từ phần mềm tính công phần màu vàng và bên cạnh là phần em đã dùng hàm để cho nó chạy theo mẫu mà em cần.
Đây chỉ là dữ liệu của 1 tuần thôi nhưng nó quá dài, kéo dài hàm như thế khiến file của em rất nặng.
Nếu được nhờ mọi người có thể giúp viết VBA cho nó để file gọn hơn.

Em xin cảm ơn!

leonguyenz · 13/2/20

nguyenquyetnd993 đã viết:
Chào mọi người!,

Em có 1 file xuất từ phần mềm tính công phần màu vàng và bên cạnh là phần em đã dùng hàm để cho nó chạy theo mẫu mà em cần.
Đây chỉ là dữ liệu của 1 tuần thôi nhưng nó quá dài, kéo dài hàm như thế khiến file của em rất nặng.
Nếu được nhờ mọi người có thể giúp viết VBA cho nó để file gọn hơn.

Em xin cảm ơn!

Tham khảo code sau:

Mã:

Sub CaiGiDay()
Dim sAr As Variant, i As Long, j As Long, rAr As Variant
Dim Rng As Range, xFd As Range, eR As Long
Dim Tmp As Variant, eNm As String, dEp As String
With Sheet3
    Set Rng = .Range("A3:C" & .Range("C1048575").End(xlUp).Row)
End With
With Sheet2
    eR = .Range("E1048575").End(xlUp).Row + 1
    sAr = .Range("A2:G" & eR).Value2
    ReDim rAr(1 To UBound(sAr, 1), 1 To 9)
    .Range("I2:Q" & eR).ClearContents
    For i = 1 To UBound(sAr, 1) - 1
        If sAr(i, 2) & sAr(i, 3) = "EMPLOYEE:" Then
            Tmp = sAr(i, 4)
            Set xFd = Rng.Find(Tmp, , , 1, , , 1)
            If Not xFd Is Nothing Then
                eNm = xFd.Offset(0, 1): dEp = xFd.Offset(0, 2)
            Else
                eNm = "": dEp = ""
            End If
        End If
        If Len(sAr(i, 1)) And IsNumeric(sAr(i, 7)) Then
            rAr(i, 1) = dEp: rAr(i, 2) = eNm
            rAr(i + 1, 2) = eNm: rAr(i + 1, 3) = Tmp
            rAr(i, 3) = Tmp: rAr(i, 4) = sAr(i + 1, 6)
            rAr(i, 5) = sAr(i, 7): rAr(i, 8) = CDate(sAr(i, 2))
        End If
    Next i
    .Range("I2").Resize(UBound(sAr, 1), 9) = rAr
End With
End Sub

nguyenquyetnd993 · 14/2/20

leonguyenz đã viết:

Tham khảo code sau:

Mã:

Sub CaiGiDay()
Dim sAr As Variant, i As Long, j As Long, rAr As Variant
Dim Rng As Range, xFd As Range, eR As Long
Dim Tmp As Variant, eNm As String, dEp As String
With Sheet3
    Set Rng = .Range("A3:C" & .Range("C1048575").End(xlUp).Row)
End With
With Sheet2
    eR = .Range("E1048575").End(xlUp).Row + 1
    sAr = .Range("A2:G" & eR).Value2
    ReDim rAr(1 To UBound(sAr, 1), 1 To 9)
    .Range("I2:Q" & eR).ClearContents
    For i = 1 To UBound(sAr, 1) - 1
        If sAr(i, 2) & sAr(i, 3) = "EMPLOYEE:" Then
            Tmp = sAr(i, 4)
            Set xFd = Rng.Find(Tmp, , , 1, , , 1)
            If Not xFd Is Nothing Then
                eNm = xFd.Offset(0, 1): dEp = xFd.Offset(0, 2)
            Else
                eNm = "": dEp = ""
            End If
        End If
        If Len(sAr(i, 1)) And IsNumeric(sAr(i, 7)) Then
            rAr(i, 1) = dEp: rAr(i, 2) = eNm
            rAr(i + 1, 2) = eNm: rAr(i + 1, 3) = Tmp
            rAr(i, 3) = Tmp: rAr(i, 4) = sAr(i + 1, 6)
            rAr(i, 5) = sAr(i, 7): rAr(i, 8) = CDate(sAr(i, 2))
        End If
    Next i
    .Range("I2").Resize(UBound(sAr, 1), 9) = rAr
End With
End Sub

Em cảm ơn ạ.
Để em chạy nếu có thêm vấn đề gì xin nhờ a giúp ạ.

nguyenquyetnd993 · 14/2/20

H

leonguyenz đã viết:

Tham khảo code sau:

Mã:

Sub CaiGiDay()
Dim sAr As Variant, i As Long, j As Long, rAr As Variant
Dim Rng As Range, xFd As Range, eR As Long
Dim Tmp As Variant, eNm As String, dEp As String
With Sheet3
    Set Rng = .Range("A3:C" & .Range("C1048575").End(xlUp).Row)
End With
With Sheet2
    eR = .Range("E1048575").End(xlUp).Row + 1
    sAr = .Range("A2:G" & eR).Value2
    ReDim rAr(1 To UBound(sAr, 1), 1 To 9)
    .Range("I2:Q" & eR).ClearContents
    For i = 1 To UBound(sAr, 1) - 1
        If sAr(i, 2) & sAr(i, 3) = "EMPLOYEE:" Then
            Tmp = sAr(i, 4)
            Set xFd = Rng.Find(Tmp, , , 1, , , 1)
            If Not xFd Is Nothing Then
                eNm = xFd.Offset(0, 1): dEp = xFd.Offset(0, 2)
            Else
                eNm = "": dEp = ""
            End If
        End If
        If Len(sAr(i, 1)) And IsNumeric(sAr(i, 7)) Then
            rAr(i, 1) = dEp: rAr(i, 2) = eNm
            rAr(i + 1, 2) = eNm: rAr(i + 1, 3) = Tmp
            rAr(i, 3) = Tmp: rAr(i, 4) = sAr(i + 1, 6)
            rAr(i, 5) = sAr(i, 7): rAr(i, 8) = CDate(sAr(i, 2))
        End If
    Next i
    .Range("I2").Resize(UBound(sAr, 1), 9) = rAr
End With
End Sub

Em chào anh!
Em còn một vấn đề nhỏ mong a giúp đỡ ạ,
Dữ liệu em lấy từ máy chấm công bị dồn vào 1 cột A file trước đó emđính kèm ở trên em đã sử dụng chức năng "text to columns"để tách cột.
nếu em chỉnh tay thì dữ liệu chia ra không bị lỗi nhưng em record macro lại nó lại bị đảo ngày tháng cho nhau ( ngày thành tháng, tháng thành ngày) .
Mong Anh giúp đỡ .
Cảm ơn anh!

leonguyenz · 15/2/20

nguyenquyetnd993 đã viết:
Em chào anh!
Em còn một vấn đề nhỏ mong a giúp đỡ ạ,
Dữ liệu em lấy từ máy chấm công bị dồn vào 1 cột A file trước đó emđính kèm ở trên em đã sử dụng chức năng "text to columns"để tách cột.
nếu em chỉnh tay thì dữ liệu chia ra không bị lỗi nhưng em record macro lại nó lại bị đảo ngày tháng cho nhau ( ngày thành tháng, tháng thành ngày) .
Mong Anh giúp đỡ .
Cảm ơn anh!

Thử lấy trực tiếp từ dữ liệu chấm công xem.

Mã:

Sub LietKe()
Dim sAr As Variant, i As Long, j As Long, rAr As Variant
Dim Rng As Range, xFd As Range, eR As Long
Dim Tmp As Variant, eNm As String, dEp As String
With Sheet3
    Set Rng = .Range("A3:C" & .Range("C1048575").End(xlUp).Row)
End With
With Sheet1
    eR = .Range("A1048575").End(xlUp).Row + 1
    sAr = .Range("A2:A" & eR).Value2
    ReDim rAr(1 To UBound(sAr, 1), 1 To 9)
    .Range("M2:U" & eR).ClearContents
    For i = 1 To UBound(sAr, 1) - 1
        If Len(sAr(i, 1)) Then
            If InStr(sAr(i, 1), "EMPLOYEE:") Then
                Tmp = Val(Trim(Mid(sAr(i, 1), 19, 7)))
                Set xFd = Rng.Find(Tmp, , , 1, , , 1)
                If Not xFd Is Nothing Then
                    eNm = xFd.Offset(0, 1): dEp = xFd.Offset(0, 2)
                Else
                    eNm = "": dEp = ""
                End If
            End If
            If Mid(sAr(i, 1), 7, 2) = "02" Then
                rAr(i, 1) = dEp: rAr(i, 2) = eNm
                rAr(i + 1, 2) = eNm: rAr(i + 1, 3) = Tmp
                rAr(i, 3) = Tmp: rAr(i, 4) = Trim(Mid(sAr(i + 1, 1), 45, 100))
                rAr(i, 5) = Trim(Mid(sAr(i, 1), 50, 100))
                rAr(i, 8) = DateSerial(2020, Val(Mid(sAr(i, 1), 7, 2)), Val(Mid(sAr(i, 1), 4, 2)))
            End If
        End If
    Next i
    .Range("M2").Resize(UBound(sAr, 1), 9) = rAr
End With
End Sub

nguyenquyetnd993 · 16/2/20

leonguyenz đã viết:

Thử lấy trực tiếp từ dữ liệu chấm công xem.

Mã:

Sub LietKe()
Dim sAr As Variant, i As Long, j As Long, rAr As Variant
Dim Rng As Range, xFd As Range, eR As Long
Dim Tmp As Variant, eNm As String, dEp As String
With Sheet3
    Set Rng = .Range("A3:C" & .Range("C1048575").End(xlUp).Row)
End With
With Sheet1
    eR = .Range("A1048575").End(xlUp).Row + 1
    sAr = .Range("A2:A" & eR).Value2
    ReDim rAr(1 To UBound(sAr, 1), 1 To 9)
    .Range("M2:U" & eR).ClearContents
    For i = 1 To UBound(sAr, 1) - 1
        If Len(sAr(i, 1)) Then
            If InStr(sAr(i, 1), "EMPLOYEE:") Then
                Tmp = Val(Trim(Mid(sAr(i, 1), 19, 7)))
                Set xFd = Rng.Find(Tmp, , , 1, , , 1)
                If Not xFd Is Nothing Then
                    eNm = xFd.Offset(0, 1): dEp = xFd.Offset(0, 2)
                Else
                    eNm = "": dEp = ""
                End If
            End If
            If Mid(sAr(i, 1), 7, 2) = "02" Then
                rAr(i, 1) = dEp: rAr(i, 2) = eNm
                rAr(i + 1, 2) = eNm: rAr(i + 1, 3) = Tmp
                rAr(i, 3) = Tmp: rAr(i, 4) = Trim(Mid(sAr(i + 1, 1), 45, 100))
                rAr(i, 5) = Trim(Mid(sAr(i, 1), 50, 100))
                rAr(i, 8) = DateSerial(2020, Val(Mid(sAr(i, 1), 7, 2)), Val(Mid(sAr(i, 1), 4, 2)))
            End If
        End If
    Next i
    .Range("M2").Resize(UBound(sAr, 1), 9) = rAr
End With
End Sub

Ngày tháng vẫn bị đảo cho nhau anh ạ.

nguyenquyetnd993 · 17/2/20

nguyenquyetnd993 đã viết:
Ngày tháng vẫn bị đảo cho nhau anh ạ.
View attachment 232052

Em lên máy công ty nó chạy được rồi anh ạ, em cảm ơn anh nhiều. Nếu có gì mới mong anh giúp đỡ thêm ạ.

Lọc và Chuyển đổi Dữ liệu theo form. (1 người xem)

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

nguyenquyetnd993

Thành viên chính thức

File đính kèm

leonguyenz

Thành viên gạo cội

File đính kèm

nguyenquyetnd993

Thành viên chính thức

nguyenquyetnd993

Thành viên chính thức

File đính kèm

leonguyenz

Thành viên gạo cội

File đính kèm

nguyenquyetnd993

Thành viên chính thức

nguyenquyetnd993

Thành viên chính thứ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