Public Sub GPE()
Dim Ws As Worksheet, sArr(), dArr(), I As Long, K 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): K = -7
ReDim dArr(1 To R * 8, 1 To 3)
For I = 1 To R
If UCase(sArr(I, 2)) = Txt Then
K = K + 8
dArr(K, 1) = sArr(I, 1)
dArr(K, 2) = sArr(I, 2)
dArr(K, 3) = sArr(I, 4)
End If
Next I
.Range("C4").Resize(1000, 3).ClearContents
If K > 0 Then .Range("C4").Resize(K, 3) = dArr
End With
End If
Next Ws
End SubNext I
.Range("C4").Resize(1000, 3).ClearContents
If K > 0 Then .Range("C4").Resize(K, 3) = dArrNext I
If K > 0 Then
.Range("C4").Resize(1000, 3).ClearContents
.Range("C4").Resize(K, 3) = dArr
End If
Ahihi,
Cảm ơn bạn nhiều , dù là Oanh Thơ chưa hiểu lắm nhưng cảm thấy rất hứng thú.
Đúng là với file thực của Oanh Thơ thì nhiều Or lắm ạ..
Một lần nữa cảm ơn bạn ạ.
Sub Main()
Dim wksData As Worksheet, wksSub As Worksheet
Dim aWksName, shItem
Set wksData = Worksheets("Data")
wksData.Range("IV1").Value = wksData.Range("D7").Value
aWksName = Array("SX", "QC", "Kho", "KT")
For Each shItem In aWksName
Set wksSub = Worksheets(CStr(shItem))
wksSub.Range("C4:E10000").Clear
wksData.Range("IV2").Value = CStr(shItem)
wksData.Range("C7:F10000").AdvancedFilter 2, wksData.Range("IV1:IV2"), wksSub.Range("C3:E3")
Next
wksData.Range("IV1:IV2").Clear
End Sub
làm tương tự, dùng Dictionary thay sheet tạm
Sub GPE()
Dim Ws As Worksheet, Darr(), Dic As Object, i As Long, R As Long, Tmp As String
Darr = Sheets("Data").Range("C9:F" & Sheets("Data").Range("C65500").End(xlUp).Row).Value
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(Darr)
If Not Dic.exists(Darr(i, 2)) And Darr(i, 2) <> "" Then
Dic.Add Darr(i, 2), 1
Dic.Add Darr(i, 2) & "#" & 1, Array(Darr(i, 1), Darr(i, 2), Darr(i, 4))
Else
Dic.Item(Darr(i, 2)) = Dic.Item(Darr(i, 2)) + 1
Tmp = Darr(i, 2) & "#" & Dic.Item(Darr(i, 2))
Dic.Add Tmp, Array(Darr(i, 1), Darr(i, 2), Darr(i, 4))
End If
Next i
For Each Ws In ThisWorkbook.Worksheets
Tmp = Ws.Name
If Dic.exists(Tmp) Then
R = Dic.Item(Tmp)
ReDim Darr(1 To R * 8, 1 To 3)
For i = 1 To R
Darr((i - 1) * 8 + 1, 1) = Dic.Item(Tmp & "#" & i)(0)
Darr((i - 1) * 8 + 1, 2) = Dic.Item(Tmp & "#" & i)(1)
Darr((i - 1) * 8 + 1, 3) = Dic.Item(Tmp & "#" & i)(2)
Next i
Ws.Range("C4").Resize(1000, 3).ClearContents
Ws.Range("C4").Resize(R * 8, 3) = Darr
End If
Next Ws
Set Dic = Nothing: Set Ws = Nothing: Erase Darr
End SubChỉ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 SubHi, 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ơ
công việc chỉ là đưa dữ liệu từ sheet data2 sang các sheet bộ phận trong cùng 1 tệp tin bạn ạ.trên từng sheet có đủ dữ liệu để xử lý, tại sao phải lấy dữ liệu từ Data2?
Sub GPE_1()
Dim dArr(), sArr(), Arr(), tArr(), Dic As Object, Ws, I As Long, k As Byte, J As Byte, N
dArr = Sheets("Data2").Range("B14:FC" & Sheets("Data2").Range("B65500").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
For k = LBound(Ws) To UBound(Ws)
tArr = Sheets(Ws(k)).Range("J14:AN14").Value
ReDim Arr(1 To 3, 1 To 31)
sArr = Sheets(Ws(k)).Range("G1:G" & Sheets(Ws(k)).Range("G65500").End(xlUp).Row).Value
For I = 15 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)), (Day(tArr(1, J)) - 1) * 5 + N + 3)
Next J
Next N
Sheets(Ws(k)).Range("J" & I + 3).Resize(3, 31) = Arr
End If
Next I
Next k
Set Dic = Nothing
End Sub@Nguyễn Hoàng Oanh Thơ,
(1) Vậy mọi thứ đã đầy đủ rồi
(2) hình như lỗi chính tả...
(3)Hình như thiếu cái gì đó \Mã:filename = ThisWorkbook.Path & [COLOR=#0000ff]"" [/COLOR]& bo_phan(index) & ".xls"
Oanh Thơ chưa hiểu ý bạn lắm ạ, nếu Oanh Thơ trả lời không đúng ý bạn mong bạn giải thích thêm ạ.
Public Sub GPE_2()
Dim Dic As Object, sArr(), dArr(), tArr(), Tem As Long, iTm As Long
Dim I As Long, iK As Long, J As Long, Col As Long, N As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data2")
tArr = .Range("G1", .Range("G1").End(xlToRight)).Value
sArr = .Range("B14", .Range("B65536").End(xlUp)).Resize(, 158).Value
End With
For I = 1 To UBound(sArr)
Dic.Item(sArr(I, 1)) = I
Next I
For N = 1 To UBound(tArr, 2)
With Sheets(tArr(1, N))
Rws = .Range("G65536").End(xlUp).Row
For iK = 15 To Rws Step 8
Tem = .Range("G" & iK): Col = 0
If Dic.Exists(Tem) Then
iTm = Dic.Item(Tem)
ReDim dArr(1 To 2, 1 To 31)
For J = 5 To 158 Step 5
Col = Col + 1
dArr(1, Col) = sArr(iTm, J)
dArr(2, Col) = sArr(iTm, J + 1)
Next J
.Range("J" & iK + 4).Resize(2, 31) = dArr
End If
Next iK
End With
Next N
Set Dic = Nothing
MsgBox "Da thuc hien xong.", , "GiaiPhapExcel"
End Subcủa bạn ,như đã nêu ở bài 41 vì Oanh Thơ chưa biết cách vận dụng cho file thật của mình thôi ạ.
