Nhờ hướng dẫn giúp cách sử dụng vòng lập For Each

[NguyenNT221100]

Em có một yêu cầu công việc là tìm và ghi dữ liệu từ một nguồn là file Excel ra Worksheet khác.
Dữ liệu của em gồm có khoảng 100 dòng (không trùng nhau và 365 cột (tương ứng với 1 năm làm việc)
Trong bảng dữ liệu thì có chỗ có số liệu chỗ không có, em muốn tìm chỗ có số liệu thì lây và ghi vào worksheet khác.
Nhưng điều kiện là ngoài việc lấy được số liệu chỗ tìm được còn phải ghi thêm dữ liệu ở chỗ đầu dòng và đầu cột.
Em đã thử dùng vòng lập For Each nhưng chỉ lấy được dữ liệu chỗ có dữ liệu "ruột" mà không biết cách lấy thêm dữ liệu tương ứng khác (nêu trên)
Em gởi kèm file mô tả dữ liệ nguồn và kết quả muốn nhận được sau khi chạy code. Nhờ anh chị hướng dấn thêm cho em với ạ.
Em xin cảm ơn nhiều nhiều.

 

[Nhattanktnn]

Em có một yêu cầu công việc là tìm và ghi dữ liệu từ một nguồn là file Excel ra Worksheet khác.
Dữ liệu của em gồm có khoảng 100 dòng (không trùng nhau và 365 cột (tương ứng với 1 năm làm việc)
Trong bảng dữ liệu thì có chỗ có số liệu chỗ không có, em muốn tìm chỗ có số liệu thì lây và ghi vào worksheet khác.
Nhưng điều kiện là ngoài việc lấy được số liệu chỗ tìm được còn phải ghi thêm dữ liệu ở chỗ đầu dòng và đầu cột.
Em đã thử dùng vòng lập For Each nhưng chỉ lấy được dữ liệu chỗ có dữ liệu "ruột" mà không biết cách lấy thêm dữ liệu tương ứng khác (nêu trên)
Em gởi kèm file mô tả dữ liệ nguồn và kết quả muốn nhận được sau khi chạy code. Nhờ anh chị hướng dấn thêm cho em với ạ.
Em xin cảm ơn nhiều nhiều.
View attachment 280347

Không phải for each có được không?

Option Explicit

Sub UnpivotColumns()
Dim sArr(), dArr(), I As Long, iCol As Long, iRws As Long, uB1 As Long, uB2 As Long
sArr() = Sheets("Sheet1").Range("A1:K3").Value
uB1 = UBound(sArr, 1): uB2 = UBound(sArr, 2)
ReDim dArr(1 To uB1 * uB2, 1 To 3)
For iRws = 2 To uB1
    For iCol = 2 To uB2
        If sArr(iRws, iCol) <> vbNullString Then
            I = I + 1
            dArr(I, 1) = sArr(iRws, 1)
            dArr(I, 2) = sArr(iRws, iCol)
            dArr(I, 3) = sArr(1, iCol)
        End If
    Next
Next
Sheets("KQ").Range("A2").Resize(Rows.Count - 1, 3).ClearContents
Sheets("KQ").Range("A2").Resize(I, 3).Value = dArr
End Sub

 

[NguyenNT221100]

Dạ cảm ơn bác nhiều ạ.
Code này cũng được, em sẽ tự tìm hiểu và tùy chỉnh thêm cho sát với thực tế yêu cầu công việc.
PS : Vì em đang mò mẫm với For Each nên em gọi ý For Each thôi chứ không có gì đặc biệt.
Một lần nữa xin cảm ơn và chúc bác nhiều sức khỏe

 

[NguyenNT221100]

Em chào bác @Nhattanktnn
Dựa theo code bác giúp hôm trước em đã chỉnh sửa chút xíu và lấy được thông tin từ nguồn dữ liệu gốc. Nhưng mới chỉ dừng lại ở việc lấy từ đầu đến cuối trong khi yêu cầu công việc của em thì thông tin không phải lúc nào cũng lấy từ đầu đến cuối. Có khi phải lấy ở giữ. (người dùng chọn lấy theo một khoảng thời gian nhất định, có ngày bắt đầu và ngày kết thúc)
Em gởi kèm file có dữ liệu mô tả gần sát với công việc của em (phần em tô màu vàng trong Sheet DATA). Mới sáng em đã làm phiền bác thì thật là ngại quá nhưng em không làm nổi nên em nhờ bác đã thương thì thương cho trót. Nếu có thời gian nhờ bác giúp em thêm chút xíu nữa cho giống với yêu cầu sau ạ.

Dữ liệu nguồn được tô màu vàng trong Sheet DATA (ngoài phần tô màu ra thì dùng cho việc khác)
Người dùng khi lấy thông tin có thể cung cấp yêu cầu ngày bắt đầu và ngày kết thúc (dòng số 10)
Luôn luôn lấy một khoảng thời gian liền mạch theo kiểu từ ngày nào đến ngày nào.
Cảm ơn bác ạ

 

[bebo021999]

Nhập ngày vào ô H1 và H2 của sheet "KQ1" rồi xem kết quả nhé.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, lc&, i&, j&, k&, rng, arr(1 To 1000000, 1 To 4), startC&, fromD As Double, toD As Double
If Intersect(Target, Range("H1:H2")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Range("A1:D1000000").ClearContents
fromD = Range("H1").Value2
toD = Range("H2").Value2
With Sheets("DATA")
    lr = .Cells(Rows.Count, "D").End(xlUp).Row
    lc = .Cells(10, Columns.Count).End(xlToLeft).Column
    If fromD < .Range("K10") Then
        MsgBox """Tu ngay: "" phai lon hon hoac bang " & .Range("K10").Value & "! vui long chon lai."
    ElseIf toD > .Cells(10, lc) Then
        MsgBox """Den ngay: "" phai nho hon hoac bang " & .Cells(10, lc).Value & "! vui long chon lai."
    Exit Sub
    End If
        startC = fromD - .Range("K10") + 8
        rng = .Range("D10", .Cells(lr, lc))
        For i = 2 To lr - 9
            For j = startC To startC + toD - fromD
                If rng(i, j) <> "" Then
                    k = k + 1
                    arr(k, 1) = rng(i, 1): arr(k, 2) = "C111": arr(k, 3) = rng(i, j): arr(k, 4) = rng(1, j)
                End If
            Next
        Next
End With
If k > 0 Then Range("A1").Resize(k, 4).Value = arr
Application.ScreenUpdating = True
End Sub

 

[Nhattanktnn]

Em chào bác @Nhattanktnn
Dựa theo code bác giúp hôm trước em đã chỉnh sửa chút xíu và lấy được thông tin từ nguồn dữ liệu gốc. Nhưng mới chỉ dừng lại ở việc lấy từ đầu đến cuối trong khi yêu cầu công việc của em thì thông tin không phải lúc nào cũng lấy từ đầu đến cuối. Có khi phải lấy ở giữ. (người dùng chọn lấy theo một khoảng thời gian nhất định, có ngày bắt đầu và ngày kết thúc)
Em gởi kèm file có dữ liệu mô tả gần sát với công việc của em (phần em tô màu vàng trong Sheet DATA). Mới sáng em đã làm phiền bác thì thật là ngại quá nhưng em không làm nổi nên em nhờ bác đã thương thì thương cho trót. Nếu có thời gian nhờ bác giúp em thêm chút xíu nữa cho giống với yêu cầu sau ạ.

Dữ liệu nguồn được tô màu vàng trong Sheet DATA (ngoài phần tô màu ra thì dùng cho việc khác)
Người dùng khi lấy thông tin có thể cung cấp yêu cầu ngày bắt đầu và ngày kết thúc (dòng số 10)
Luôn luôn lấy một khoảng thời gian liền mạch theo kiểu từ ngày nào đến ngày nào.
Cảm ơn bác ạ

Gửi bạn tham khảo:

Option Explicit

Sub UnpivotColumns()
Dim sArr(), dArr(), I As Long, lR As Long, lC As Long, iCol As Long, iRws As Long, uB1 As Long, uB2 As Long
Dim fDate As Double, lDate As Double, minCol As Long, maxCol As Long
Const fR As Long = 10              'Dong dau tien (tieu de) -> Sua theo thuc te du lieu
Const fC As Long = 4 'Cot D     'Cot dau tien (Code) -> Sua theo thuc te du lieu
fDate = DateSerial(2022, 4, 1) ' ngay bat dau can trich xuat : 01/04/2022 (dd/mm/yyyy) -> Sua theo mong muon
lDate = DateSerial(2022, 4, 20) ' ngay bat dau can trich xuat : 01/04/2022 (dd/mm/yyyy) -> Sua theo mong muon
If lDate < fDate Then MsgBox "Loi: Ngay sau nho hon ngay truoc": Exit Sub
With Sheets("Data")
    lR = .Cells(Rows.Count, fC).End(xlUp).Row
    lC = .Cells(fR, Columns.Count).End(xlToLeft).Column
    sArr() = .Range(.Cells(fR, fC), .Cells(lR, lC)).Value2
End With
uB1 = UBound(sArr, 1): uB2 = UBound(sArr, 2)
For iCol = 2 To uB2 'Duyet cot tieu de de? tim ngay thoa man dieu kien
    If sArr(1, iCol) = fDate Then minCol = iCol
    If sArr(1, iCol) = lDate Then maxCol = iCol
Next
If minCol = 0 Or maxCol = 0 Then MsgBox "Khong tim thay cot theo dieu kien": Exit Sub
If maxCol < minCol Then MsgBox "Loi: Cot ngay sau nho hon cot ngay truoc": Exit Sub
ReDim dArr(1 To (maxCol - minCol + 1) * uB1, 1 To 4)

For iRws = 2 To UBound(sArr, 1)
    For iCol = minCol To maxCol
        If sArr(iRws, iCol) <> vbNullString Then
            I = I + 1
            dArr(I, 1) = sArr(iRws, 1)      'Lay ma hang
            dArr(I, 2) = "CV11"               'Cot trong
            dArr(I, 3) = sArr(iRws, iCol)   ' dArr(I, 2) 'So luong
            dArr(I, 4) = sArr(1, iCol)         'dArr(I, 3) 'Ngay
        End If
    Next
Next
If I Then
    Sheets("KQ").Range("A2").Resize(Rows.Count - 1, 4).ClearContents
    Sheets("KQ").Range("A2").Resize(I, 4).Value = dArr
End If
End Sub

 

[NguyenNT221100]

Dạ em cảm ơn 2 bác @bebo021999 và @Nhattanktnn
Em xin được sử dụng code của 2 bác để điều chỉnh vào yêu cầu công việc của em
Chúc 2 bán nhều sức khỏe. Có gì khó mong nhận được giúp đỡ nhiệt tình ạ

 

[Hoàng Tuấn 868]

Chúc 2 bán nhều sức khỏe.

Món này khối cô muốn mua.

 

[VetMini]

Món này khối cô muốn mua.

Cô Đông Huyền có mua hôn?

 

[NguyenNT221100]

Món này khối cô muốn mua.

Dạo này mắt mũi tèm lem.
Đánh cứ dính phím bác ạ.
Thất lễ thất lễ...