Sao chép dữ liệu trong ô theo số lượng

[Nguyễn Hồng Lam]

Chào mọi người, bây giờ mình cần thực hiện sao chép các mặt hàng trong nội dung "Mặt hàng bán" theo "Số lượng đại lý đặt mua" như hình và file ví dụ. Mọi người giúp mình với nhé:

 

[huuthang_bd]

"Sao chép" là sao nhỉ? Nhìn hình có vẻ như là đếm và có thể dùng hàm Countif.

 

[Nguyễn Hồng Lam]

"Sao chép" là sao nhỉ? Nhìn hình có vẻ như là đếm và có thể dùng hàm Countif.

Ý mình là ví dụ Táo Mỹ có 15 đại lý đặt mua, giờ mình cần sao chép 15 dòng Táo Mỹ để mình nhập các thông tin khác nữa ấy mà

 

[Phuocam]

Giải trí một chút

Sub test()
Dim i As Long, ii As Long, maxR As Long, k As Long
Dim a, b
a = Sheet1.Range("A1").CurrentRegion.Value
maxR = Application.Sum(Sheet1.Range("D:D"))
ReDim b(1 To maxR, 1 To 8)
For i = 2 To UBound(a, 1)
    For ii = 1 To a(i, 4)
        k = k + 1
        b(k, 1) = ii
        b(k, 2) = a(i, 2)
    Next ii
Next i
If k > 0 Then
    With Sheet1.Range("H2").Resize(k, 8)
        .Value = b
        .Borders.LineStyle = 1
    End With
End If

End Sub

 

[huuthang_bd]

Sub CreateTable()
Dim aData As Variant, aResult() As Variant, lTotal As Long, i As Long, j As Long, n As Long
With Sheet1.Range("B2:D" & Sheet1.Cells(&H100000, 4).End(xlUp).Row)
    aData = .Value
    lTotal = Application.Sum(.Columns(3))
End With
ReDim aResult(1 To lTotal, 1 To 2)
For i = 1 To UBound(aData, 1)
    For j = 1 To aData(i, 3)
        n = n + 1
        aResult(n, 1) = j
        aResult(n, 2) = aData(i, 1)
    Next
Next
Sheet1.Range("H2:O" & Sheet1.Cells(&H100000, 8).End(xlUp).Row).Clear
Sheet1.Range("H2").Resize(lTotal, 2).Value = aResult
Sheet1.Range("H2").Resize(lTotal, 8).Borders.LineStyle = xlContinuous
End Sub

 

[Nguyễn Hồng Lam]

Sub CreateTable()
Dim aData As Variant, aResult() As Variant, lTotal As Long, i As Long, j As Long, n As Long
With Sheet1.Range("B2:D" & Sheet1.Cells(&H100000, 4).End(xlUp).Row)
    aData = .Value
    lTotal = Application.Sum(.Columns(3))
End With
ReDim aResult(1 To lTotal, 1 To 2)
For i = 1 To UBound(aData, 1)
    For j = 1 To aData(i, 3)
        n = n + 1
        aResult(n, 1) = j
        aResult(n, 2) = aData(i, 1)
    Next
Next
Sheet1.Range("H2:O" & Sheet1.Cells(&H100000, 8).End(xlUp).Row).Clear
Sheet1.Range("H2").Resize(lTotal, 2).Value = aResult
Sheet1.Range("H2").Resize(lTotal, 8).Borders.LineStyle = xlContinuous
End Sub

Mình copy rồi nhưng add-in vào chẳng chạy được. Tới đây rồi làm sao nữa vậy bạn

Bài đã được tự động gộp: 17/6/20

Giải trí một chút

Sub test()
Dim i As Long, ii As Long, maxR As Long, k As Long
Dim a, b
a = Sheet1.Range("A1").CurrentRegion.Value
maxR = Application.Sum(Sheet1.Range("D:D"))
ReDim b(1 To maxR, 1 To 8)
For i = 2 To UBound(a, 1)
    For ii = 1 To a(i, 4)
        k = k + 1
        b(k, 1) = ii
        b(k, 2) = a(i, 2)
    Next ii
Next i
If k > 0 Then
    With Sheet1.Range("H2").Resize(k, 8)
        .Value = b
        .Borders.LineStyle = 1
    End With
End If

End Sub

Mình copy rồi nhưng add-in vào chẳng chạy được. Tới đây rồi làm sao nữa vậy bạn

 

[huuthang_bd]

Đưa vào file cho bạn luôn vậy.

 

[Nguyễn Hồng Lam]

Đưa vào file cho bạn luôn vậy.

Được rồi bạn, cám ơn bạn rất nhiều./.