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 Sub
