Copy và nhân ra nhiều hàng

[nnt32002]

Nhờ các anh chị em giúp đỡ dùng công thức gì để theo file đính kèm. Xin cảm ơn nhiều.

 

[HUONGHCKT]

Nhờ các anh chị em giúp đỡ dùng công thức gì để theo file đính kèm. Xin cảm ơn nhiều.

nếu bạn không chê làm bàng VBA thì hãy copy và paste vào modul1 và chạy thử.
kết quả trả về ở cột E từ E2 xuống khoảng gần 65k dòng

Sub NhanHang()
Dim I&, J&, R&, k&, t&, Lr
Dim Arr(), KQ()
Dim dic As Object
With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A2:A" & Lr).Value
R = UBound(Arr, 1)
ReDim KQ(1 To R * 7, 1 To 1)
Set dic = CreateObject("Scripting.Dictionary")
For I = 1 To R
    DK = Arr(I, 1)
        If Not dic.exists(DK) Then
            t = t + 1
            dic.Add (DK), t
            For J = 7 To 1 Step -1
                k = t * 7 - J
                KQ(k + 1, 1) = Arr(I, 1)
            Next J
        
        End If
Next I
If t Then
    .[E2].Resize(t * 7, 1) = KQ
  '  .[K2].Resize(t * 7, 1).Borders.LineStyle = 1
End If
End With
Set dic = Nothing
End Sub

 

[Ba Tê]

nếu bạn không chê làm bàng VBA thì hãy copy và paste vào modul1 và chạy thử.
kết quả trả về ở cột E từ E2 xuống khoảng gần 65k dòng

Sub NhanHang()
Dim I&, J&, R&, k&, t&, Lr
Dim Arr(), KQ()
Dim dic As Object
With Sheet1
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A2:A" & Lr).Value
R = UBound(Arr, 1)
ReDim KQ(1 To R * 7, 1 To 1)
Set dic = CreateObject("Scripting.Dictionary")
For I = 1 To R
    DK = Arr(I, 1)
        If Not dic.exists(DK) Then
            t = t + 1
            dic.Add (DK), t
            For J = 7 To 1 Step -1
                k = t * 7 - J
                KQ(k + 1, 1) = Arr(I, 1)
            Next J
       
        End If
Next I
If t Then
    .[E2].Resize(t * 7, 1) = KQ
  '  .[K2].Resize(t * 7, 1).Borders.LineStyle = 1
End If
End With
Set dic = Nothing
End Sub

Với yêu cầu này thì đâu cần dùng Dic .

Public Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long
With Sheet1
    sArr = .Range("A2", .Range("A2").End(xlDown)).Value
    R = UBound(sArr)
    ReDim dArr(1 To R * 7, 1 To 2)
    For I = 1 To R
        For J = 1 To 7
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = "FA0" & J
        Next J
    Next I
    .Range("E2").Resize(K, 2) = dArr
End With
End Sub

 

[HUONGHCKT]

Với yêu cầu này thì đâu cần dùng Dic .

Public Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long
With Sheet1
    sArr = .Range("A2", .Range("A2").End(xlDown)).Value
    R = UBound(sArr)
    ReDim dArr(1 To R * 7, 1 To 2)
    For I = 1 To R
        For J = 1 To 7
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = "FA0" & J
        Next J
    Next I
    .Range("E2").Resize(K, 2) = dArr
End With
End Sub

Tôi nghĩ là dữ liệu nhiều như vậy thì có thể có trùng nên dùng Dic để loại bỏ trùng mà.

 

[Ba Tê]

Tôi nghĩ là dữ liệu nhiều như vậy thì có thể có trùng nên dùng Dic để loại bỏ trùng mà.

Cũng là "lo xa"? Người ta đâu có yêu cầu bỏ trùng:

Muốn kết quả là: nhân cell a2 thành 7 hàng giống nhau và tiếp tục là a3...​

 

[HUONGHCKT]

Cũng là "lo xa"? Người ta đâu có yêu cầu bỏ trùng:

Muốn kết quả là: nhân cell a2 thành 7 hàng giống nhau và tiếp tục là a3...​

Cũng là đề phòng trường hợp yêu cầu phát sinh. Cảm ơn Anh đã quan tâm chỉ giáo. Trân trọng

 

[nnt32002]

Rất cảm ơn sự giúp đỡ nhiệt tình của các anh chị. HUONGHCHT, Ba Tê

 

[lamnd0931]

Em chào các anh, cùng câu hỏi nhưng em muốn thay vì tạo ra 7 dòng khác nhau. Em cần tạo ra số dòng theo 1 cột số lượng bên cạnh thì sao ạ. em cảm ơn nhiều!

 

[HieuCD]

Em chào các anh, cùng câu hỏi nhưng em muốn thay vì tạo ra 7 dòng khác nhau. Em cần tạo ra số dòng theo 1 cột số lượng bên cạnh thì sao ạ. em cảm ơn nhiều!

Làm tương tự
Thay R*7 bằng con số ước tính hơi dư số dòng kết quả: ReDim dArr(1 To R * 7, 1 To 2)
Thay số 7 bằng cột " cột số lượng bên cạnh": For J = 1 To 7

 

[lamnd0931]

Em cần thêm chỗ này ạ, ví dụ: 114284 cần 2 dòng, 114285 cần 3 dòng,.... Em cảm ơn !

 

[HieuCD]

Em cần thêm chỗ này ạ, ví dụ: 114284 cần 2 dòng, 114285 cần 3 dòng,.... Em cảm ơn !
View attachment 268474

For J = 1 To .range("B"&i).value

 

[lamnd0931]

For J = 1 To .range("B"&i).value

Em bị lỗi như này ạ. mong anh giúp đỡ

 

[HieuCD]

Em bị lỗi như này ạ. mong anh giúp đỡ
View attachment 268478

Tại sao có những dòng không có số lượng?
Gởi file excel lên

 

[lamnd0931]

Tại sao có những dòng không có số lượng?
Gởi file excel lên

Đây a xem giúp em! Em chỉ ví dụ lấy 5 dòng đầu tiên thử thôi á

 

[HieuCD]

Đây a xem giúp em! Em chỉ ví dụ lấy 5 dòng đầu tiên thử thôi á

Dữ liệu và kết quả ở sheet2

Sub ABC()
  Dim sArr(), res(), eRow&, sRow&, i&, r&, k&
  With Sheet2
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 2 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sArr = .Range("A2:B" & eRow).Value
    ReDim res(1 To Application.Sum(Range("B2:B" & eRow)), 1 To 1)
    sRow = UBound(sArr)
    For i = 1 To sRow
      For r = 1 To sArr(i, 2)
        k = k + 1
        res(k, 1) = sArr(i, 1)
      Next r
    Next i
    .Range("E2").Resize(k) = res
  End With
End Sub

 

[lamnd0931]

Dữ liệu và kết quả ở sheet2

Sub ABC()
  Dim sArr(), res(), eRow&, sRow&, i&, r&, k&
  With Sheet2
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 2 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sArr = .Range("A2:B" & eRow).Value
    ReDim res(1 To Application.Sum(Range("B2:B" & eRow)), 1 To 1)
    sRow = UBound(sArr)
    For i = 1 To sRow
      For r = 1 To sArr(i, 2)
        k = k + 1
        res(k, 1) = sArr(i, 1)
      Next r
    Next i
    .Range("E2").Resize(k) = res
  End With
End Sub

Chân thành cảm ơn anh, em tìm hơn tháng nay mới tìm được anh giúp đỡ. Cảm ơn anh rất nhiều, chúc anh cuối tuần vui vẻ!!!