Help Code Macro Tạo Repeat Item

[cando129]

Chào Anh/Chị,
do mình gà mờ nên cũng không biết diễn tã tiêu đề ntn,mong các anh chị thông cảm
nhờ anh chị giúp tôi vấn đề này (file đính kèm),
tạo một macro button,do không biết diễn tã từ ngữ ntn nên không thể nói ra đây được mà phải dùng ví dụ.
anh/chị xem nếu hiểu thì vui lòng giúp tôi.
chân thành cảm ơn!

 

[leonguyenz]

Chào Anh/Chị,
do mình gà mờ nên cũng không biết diễn tã tiêu đề ntn,mong các anh chị thông cảm
nhờ anh chị giúp tôi vấn đề này (file đính kèm),
tạo một macro button,do không biết diễn tã từ ngữ ntn nên không thể nói ra đây được mà phải dùng ví dụ.
anh/chị xem nếu hiểu thì vui lòng giúp tôi.
chân thành cảm ơn!

Tham khảo code cùi bắp này:

Sub LietKeGPE()
Dim aLs(), sAr(), i As Integer, j As Integer, k As Integer, reAr()
Dim Tmp As String, aTmp() As String, Dic As Object, n As Integer, dAr()
Set Dic = CreateObject("Scripting.Dictionary")
aLs = Sheet1.Range("H5:H" & Sheet1.Range("H65535").End(xlUp).Row).Value
sAr = Sheet1.Range("A3:C" & Sheet1.Range("A65535").End(xlUp).Row).Value
ReDim reAr(1 To UBound(aLs, 1) * UBound(sAr, 1), 1 To 3)
Sheet2.Range("A2:C65535").ClearContents
For i = 1 To UBound(sAr, 1)
    For j = 1 To UBound(aLs, 1)
        If Not Dic.Exists(aLs(j, 1)) Then Dic.Add aLs(j, 1), j
    Next j
    If sAr(i, 3) = "All store" Then
        For j = 1 To UBound(aLs, 1)
            n = n + 1: reAr(n, 1) = aLs(j, 1)
            reAr(n, 2) = sAr(i, 1): reAr(n, 3) = sAr(i, 2)
        Next j
    ElseIf InStr(sAr(i, 3), "-") Then
        Tmp = Replace(Replace(sAr(i, 3), "All store(-", ""), ")", "")
        aTmp = Split(Tmp, ",")
        For j = 0 To UBound(aTmp)
            If Dic.Exists(Val("100" & aTmp(j))) Then Dic.Remove Val(("100" & aTmp(j)))
        Next j
        dAr = Dic.keys
        For j = 0 To Dic.Count - 1
            n = n + 1: reAr(n, 1) = dAr(j)
            reAr(n, 2) = sAr(i, 1): reAr(n, 3) = sAr(i, 2)
        Next j
        Dic.RemoveAll
    Else
        aTmp = Split(sAr(i, 3), ",")
        For j = 0 To UBound(aTmp)
            n = n + 1: reAr(n, 1) = "100" & aTmp(j)
            reAr(n, 2) = sAr(i, 1): reAr(n, 3) = sAr(i, 2)
        Next j
    End If
Next i
If n Then Sheet2.Range("A2").Resize(n, 3) = reAr
End Sub

 

[cando129]

Tham khảo code cùi bắp này:

Sub LietKeGPE()
Dim aLs(), sAr(), i As Integer, j As Integer, k As Integer, reAr()
Dim Tmp As String, aTmp() As String, Dic As Object, n As Integer, dAr()
Set Dic = CreateObject("Scripting.Dictionary")
aLs = Sheet1.Range("H5:H" & Sheet1.Range("H65535").End(xlUp).Row).Value
sAr = Sheet1.Range("A3:C" & Sheet1.Range("A65535").End(xlUp).Row).Value
ReDim reAr(1 To UBound(aLs, 1) * UBound(sAr, 1), 1 To 3)
Sheet2.Range("A2:C65535").ClearContents
For i = 1 To UBound(sAr, 1)
    For j = 1 To UBound(aLs, 1)
        If Not Dic.Exists(aLs(j, 1)) Then Dic.Add aLs(j, 1), j
    Next j
    If sAr(i, 3) = "All store" Then
        For j = 1 To UBound(aLs, 1)
            n = n + 1: reAr(n, 1) = aLs(j, 1)
            reAr(n, 2) = sAr(i, 1): reAr(n, 3) = sAr(i, 2)
        Next j
    ElseIf InStr(sAr(i, 3), "-") Then
        Tmp = Replace(Replace(sAr(i, 3), "All store(-", ""), ")", "")
        aTmp = Split(Tmp, ",")
        For j = 0 To UBound(aTmp)
            If Dic.Exists(Val("100" & aTmp(j))) Then Dic.Remove Val(("100" & aTmp(j)))
        Next j
        dAr = Dic.keys
        For j = 0 To Dic.Count - 1
            n = n + 1: reAr(n, 1) = dAr(j)
            reAr(n, 2) = sAr(i, 1): reAr(n, 3) = sAr(i, 2)
        Next j
        Dic.RemoveAll
    Else
        aTmp = Split(sAr(i, 3), ",")
        For j = 0 To UBound(aTmp)
            n = n + 1: reAr(n, 1) = "100" & aTmp(j)
            reAr(n, 2) = sAr(i, 1): reAr(n, 3) = sAr(i, 2)
        Next j
    End If
Next i
If n Then Sheet2.Range("A2").Resize(n, 3) = reAr
End Sub

cảm ơn Anh nhiều!