Chỉnh lại code bài #3, cho nó chạy "vớ vẫn" một chút chắc cũng không lâu.
Public Sub GPE()
Dim Ws As Worksheet, sArr(), dArr(), I As Long, Col As Long, R As Long, Txt As String
With Sheets("Data")
sArr = .Range("C9", .Range("C65536").End(xlUp)).Resize(, 4).Value
R = UBound(sArr)
End With
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "Data" Then
With Ws
Txt = UCase(.Name): Col = 0
ReDim dArr(1 To 2, 1 To R)
For I = 1 To R
If "ABC " & UCase(sArr(I, 2)) = Txt Then
Col = Col + 1
dArr(1, Col) = sArr(I, 4)
dArr(2, Col) = sArr(I, 1)
End If
Next I
.Range("D3:D4").Resize(, 1000).ClearContents
If Col > 0 Then .Range("D3:D4").Resize(, Col) = dArr
End With
End If
Next Ws
End Sub
bạn chạy code mới
Sub GPE()
Dim Ws As Worksheet, Darr(), Dic As Object, i As Long, C As Long, Tmp As String
Darr = Sheets("Data").Range("C8:F" & Sheets("Data").Range("C65500").End(xlUp).Row).Value
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(Darr)
If Darr(i, 2) <> "" Then
Tmp = "ABC " & Darr(i, 2)
If Not Dic.exists(Tmp) Then
Dic.Add Tmp, 1
Dic.Add Tmp & "#" & 1, Array(Darr(i, 1), Darr(i, 4))
Else
Dic.Item(Tmp) = Dic.Item(Tmp) + 1
Tmp = Tmp & "#" & Dic.Item(Tmp)
Dic.Add Tmp, Array(Darr(i, 1), Darr(i, 4))
End If
End If
Next i
For Each Ws In ThisWorkbook.Worksheets
Tmp = Ws.Name
If Dic.exists(Tmp) Then
C = Dic.Item(Tmp)
ReDim Darr(1 To 2, 1 To C)
For i = 1 To C
Darr(1, i) = Dic.Item(Tmp & "#" & i)(1)
Darr(2, i) = Dic.Item(Tmp & "#" & i)(0)
Next i
Ws.Range("D3").Resize(2, 1000).ClearContents
Ws.Range("D3").Resize(2, C) = Darr
End If
Next Ws
Set Dic = Nothing: Set Ws = Nothing: Erase Darr
End Sub
Hi, vẫn là cái tên chưa thân nhưng quen quen, Xin cảm ơn bạn HieuCD rất nhiều ạ.
hic ngại quá
Oanh Thơ xin trân trọng cảm ơn các bạn và diễn đàn đã giúp đỡ Oanh Thơ thực hiện được bài toán 1 và 2 trong chủ đề này ạ.
Hiện tại với chủ đề này Oanh Thơ vẫn còn một vướng mắc nữa đó bài toán 3 này ạ...
Câu hỏi và kết quả mong muốn Oanh Thơ đã nêu trong file đính kèm ạ.
Kính mong các bạn tiếp tục giúp đỡ ạ.
Trân trọng cảm ơn.
Oanh Thơ
"a" ở file thật là giống nhau hay khác nhau? và đã có sẵn dữ liệu "a" ứng với 31 ngày? Đã tạo 31 ngày ứng với tháng đó? Có cần tạo tự động số ngày tương ứng với tháng chỉ định?
Không cần file thật, dữ liệu minh họa tương tự file thật là được (minh họa "a" hết thì khó hiểu)
(1) Nhập vào file mà bạn đã đính kèm phải không? Hay mỗi bộ phận một file để tự nhập dữ liệu vào?
code chỉ thay thế Hàm Vlookup như trong file mẩuOanh Thơ xin trân trọng cảm ơn các bạn và diễn đàn đã giúp đỡ Oanh Thơ thực hiện được bài toán 1 và 2 trong chủ đề này ạ.
Hiện tại với chủ đề này Oanh Thơ vẫn còn một vướng mắc nữa đó bài toán 3 này ạ...
Câu hỏi và kết quả mong muốn Oanh Thơ đã nêu trong file đính kèm ạ.
Kính mong các bạn tiếp tục giúp đỡ ạ.
Trân trọng cảm ơn.
Oanh Thơ
Sub GPE()
Dim Darr(), Sarr(), Arr(), Tarr(), Dic As Object, Ws, i As Long, k As Byte, j As Byte
Darr = Sheets("Data2").Range("F9:FE" & Sheets("Data2").Range("F65500").End(xlUp).Row).Value
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(Darr)
If Darr(i, 1) <> "" And Not Dic.exists(Darr(i, 1)) Then Dic.Add Darr(i, 1), i
Next i
Ws = Array("SX", "QC", "Kho", "KT") 'Khai báo tên các Sheet
Tarr = Sheets(Ws(0)).Range("H3:AL3").Value
For k = LBound(Ws) To UBound(Ws)
ReDim Arr(1 To 3, 1 To 31)
Sarr = Sheets(Ws(k)).Range("E1:E" & Sheets(Ws(k)).Range("E65500").End(xlUp).Row).Value
For i = 4 To UBound(Sarr) Step 8
If Sarr(i, 1) <> "" And Dic.exists(Sarr(i, 1)) Then
For n = 1 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
If Tarr(1, j) > 0 Then Arr(n, j) = Darr(Dic.Item(Sarr(i, 1)), (Tarr(1, j) - 1) * 5 + n + 1)
Next j
Next n
Sheets(Ws(k)).Range("H" & i + 3).Resize(3, 31) = Arr
End If
Next i
Next k
Set Dic = Nothing
End SubOanh Thơ xin trân trọng cảm ơn các bạn và diễn đàn đã giúp đỡ Oanh Thơ thực hiện được bài toán 1 và 2 trong chủ đề này ạ.
Hiện tại với chủ đề này Oanh Thơ vẫn còn một vướng mắc nữa đó bài toán 3 này ạ...
Câu hỏi và kết quả mong muốn Oanh Thơ đã nêu trong file đính kèm ạ.
Kính mong các bạn tiếp tục giúp đỡ ạ.
Trân trọng cảm ơn.
Oanh Thơ
Bạn nhận xét quá chuẩn, mình không rỏ dữ liệu ở sheet Data2 và cột ngày từng sheet như thế nào nên lưỡng lự và code không hợp lý,
Tarr = Sheets(Ws(0)).Range("H3:AL3").Value
ReDim Arr(1 To 3, 1 To 31)
For k = LBound(Ws) To UBound(Ws)
Sarr = Sheets(Ws(k)).Range("E1:E" & Sheets(Ws(k)).Range("E65500").End(xlUp).Row).Value
For i = 4 To UBound(Sarr) Step 8 [COLOR=#000000]
If Sarr(i, 1) <> "" And Dic.exists(Sarr(i, 1)) Then[/COLOR]For k = LBound(Ws) To UBound(Ws)
Tarr = Sheets(Ws(k)).Range("H3:AL3").Value
ReDim Arr(1 To 3, 1 To 31)
Sarr = Sheets(Ws(k)).Range("E1:E" & Sheets(Ws(k)).Range("E65500").End(xlUp).Row).Value
For i = 4 To UBound(Sarr) Step 8
[COLOR=#000000] If Sarr(i, 1) <> "" And Dic.exists(Sarr(i, 1)) Then[/COLOR]Sub GPE1()
Dim Darr(), Arr(), Ws, i As Long, n As Byte, k As Integer, j As Byte
Ws = Array("SX", "QC", "Kho", "KT") 'Khai báo tên các Sheet
For k = LBound(Ws) To UBound(Ws)
Darr = Sheets(Ws(k)).Range("E1:AL" & Sheets(Ws(k)).Range("E65500").End(xlUp).Row + 7).Value
For i = 4 To UBound(Darr) Step 8
If Darr(i, 1) <> "" Then
ReDim Arr(1 To 3, 1 To 31)
For n = 1 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
If Darr(3, j + 3) > 0 Then Arr(n, j) = Darr(i, 1) & "/Itiem" & n & "-" & Darr(3, j + 3)
Next j
Next n
Sheets(Ws(k)).Range("H" & i + 3).Resize(3, 31) = Arr
End If
Next i
Next k
End Subcám ơn bạn, vụ khai báo dim, redim mình còn lúng túng, các kiểu dữ liệu chưa hiểu hết, đặc biệt là dùng ReDim Preserve để thay đổi kích thước mảng lúc được lúc không
Với dữ liệu + yêu cầu như trong file, tôi thấy bạn dùng VLOOKUP vậy là quá ổn rồi (với lại hàm này cũng khá "nhẹ"). Code trong trường hợp này vô cùng nguy hiểm, bởi chỉ sai 1 chút là xem như bạn hết cơ hội quay đầuOanh Thơ xin trân trọng cảm ơn các bạn và diễn đàn đã giúp đỡ Oanh Thơ thực hiện được bài toán 1 và 2 trong chủ đề này ạ.
Hiện tại với chủ đề này Oanh Thơ vẫn còn một vướng mắc nữa đó bài toán 3 này ạ...
Câu hỏi và kết quả mong muốn Oanh Thơ đã nêu trong file đính kèm ạ.
Kính mong các bạn tiếp tục giúp đỡ ạ.
Trân trọng cảm ơn.
Oanh Thơ
