Lọc và Chuyển đổi Dữ liệu theo form.

nguyenquyetnd993

Thành viên mới
Tham gia ngày
31 Tháng năm 2019
Bài viết
46
Được thích
9
Điểm
15
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!

1581574054641.png
 

File đính kèm

leonguyenz

Thành viên mới
Thành viên BQT
Moderator
Tham gia ngày
2 Tháng tám 2010
Bài viết
4,533
Được thích
7,945
Điểm
610
Nơi ở
Bình Dương
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
 

File đính kèm

nguyenquyetnd993

Thành viên mới
Tham gia ngày
31 Tháng năm 2019
Bài viết
46
Được thích
9
Điểm
15
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

Thành viên mới
Tham gia ngày
31 Tháng năm 2019
Bài viết
46
Được thích
9
Điểm
15
H
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!
1581667773007.png1581667553948.png
 

File đính kèm

leonguyenz

Thành viên mới
Thành viên BQT
Moderator
Tham gia ngày
2 Tháng tám 2010
Bài viết
4,533
Được thích
7,945
Điểm
610
Nơi ở
Bình Dương
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
 

File đính kèm

nguyenquyetnd993

Thành viên mới
Tham gia ngày
31 Tháng năm 2019
Bài viết
46
Được thích
9
Điểm
15
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 ạ.
1581818120208.png
 
Top Bottom