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

Liên hệ QC
N

nguyenquyetnd993

Thành viên chính thức
Tham gia
31/5/19
Bài viết
53
Được thích
11
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

  • TS.xlsx
    3.3 MB · Đọc: 7
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!
Nhấp chuột vào đây để mở rộng...

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

  • TS.xlsm
    3.4 MB · Đọc: 9
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
Nhấp chuột vào đây để mở rộng...
Em cảm ơn ạ.
Để em chạy nếu có thêm vấn đề gì xin nhờ a giúp ạ.
 
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
Nhấp chuột vào đây để mở rộ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!
1581667773007.png1581667553948.png
 

File đính kèm

  • Preceda-TS Convert.xlsm
    889.9 KB · Đọc: 3
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!
Nhấp chuột vào đây để mở rộng...
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

  • Preceda-TS Convert.xlsm
    969.5 KB · Đọc: 5
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
Nhấp chuột vào đây để mở rộng...
Ngày tháng vẫn bị đảo cho nhau anh ạ.
1581818120208.png
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
2
Trả lời
23
Đọc
261
bebo021999
B
LuuAnh980
Cập nhật hợp đồng của mã vật tư theo ngày.
Trả lời
9
Đọc
73
DeTong
D
C
  • Question
Tổng hợp và nhóm nhân viên
    • Thích
Trả lời
13
Đọc
399
cubinv
C
Maika8008
  • Question
Add-In .xlam trộn dữ liệu Excel vào Word
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
25
Đọc
1K
ngochienbmt
N
T
Xin chỉ giáo thêm về hàm Filter
Trả lời
2
Đọc
79
thaibaovt
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom