Mọi người giúp mình tách tên hàng theo từng số lượng (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

hunglam123

Thành viên bị đình chỉ hoạt động
Thành viên bị đình chỉ hoạt động
Tham gia
31/3/20
Bài viết
180
Được thích
43
Chào các anh chị diễn đàn PGE . Em cần tách 1 vùng như hình đính kèm bên dưới. nhờ mọi người. xin chân thành cảm ơn
1587182222693.png
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Code này có cả đống rồi. Chịu khó mà tìm.
 
Upvote 0
Mình 'tìm' giúp cho bạn nè, mại zô.
PHP: 
Sub TaoBangVoiSoLuongBang1()
Dim J As Long, W As Integer, SoLg As Long, Dem As Integer, Dg As Integer
Dim Arr(), WF As Object

Arr() = [C3].CurrentRegion.Offset(2).Value
Set WF = Application.WorksheetFunction
SoLg = WF.Sum([C3].Resize(UBound(Arr())))
ReDim dArr(1 To SoLg, 1 To 4):       [G3].Resize(9 + SoLg, 4).Value = ""
For J = 1 To UBound(Arr())
    If Arr(J, 2) = "" Then Exit For
    For Dg = 1 To Arr(J, 2)
        W = W + 1
        dArr(W, 1) = Arr(J, 1):             dArr(W, 2) = 1
        dArr(W, 3) = Arr(J, 3):             dArr(W, 4) = Arr(J, 4)
    Next Dg
Next J
[G3].Resize(W, 4).Value = dArr():      Randomize
[g2:j2].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End Sub
 
Upvote 0
SA_DQ đã viết:
Mình 'tìm' giúp cho bạn nè, mại zô.
PHP: 
Sub TaoBangVoiSoLuongBang1()
Dim J As Long, W As Integer, SoLg As Long, Dem As Integer, Dg As Integer
Dim Arr(), WF As Object

Arr() = [C3].CurrentRegion.Offset(2).Value
Set WF = Application.WorksheetFunction
SoLg = WF.Sum([C3].Resize(UBound(Arr())))
ReDim dArr(1 To SoLg, 1 To 4):       [G3].Resize(9 + SoLg, 4).Value = ""
For J = 1 To UBound(Arr())
    If Arr(J, 2) = "" Then Exit For
    For Dg = 1 To Arr(J, 2)
        W = W + 1
        dArr(W, 1) = Arr(J, 1):             dArr(W, 2) = 1
        dArr(W, 3) = Arr(J, 3):             dArr(W, 4) = Arr(J, 4)
    Next Dg
Next J
[G3].Resize(W, 4).Value = dArr():      Randomize
[g2:j2].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End Sub
Nhấp chuột vào đây để mở rộng...
Tui muốn....1 vòng lặp "thui". Được hông ?????
 
Upvote 0
SA_DQ đã viết:
Mình 'tìm' giúp cho bạn nè, mại zô.
PHP: 
Sub TaoBangVoiSoLuongBang1()
Dim J As Long, W As Integer, SoLg As Long, Dem As Integer, Dg As Integer
Dim Arr(), WF As Object

Arr() = [C3].CurrentRegion.Offset(2).Value
Set WF = Application.WorksheetFunction
SoLg = WF.Sum([C3].Resize(UBound(Arr())))
ReDim dArr(1 To SoLg, 1 To 4):       [G3].Resize(9 + SoLg, 4).Value = ""
For J = 1 To UBound(Arr())
    If Arr(J, 2) = "" Then Exit For
    For Dg = 1 To Arr(J, 2)
        W = W + 1
        dArr(W, 1) = Arr(J, 1):             dArr(W, 2) = 1
        dArr(W, 3) = Arr(J, 3):             dArr(W, 4) = Arr(J, 4)
    Next Dg
Next J
[G3].Resize(W, 4).Value = dArr():      Randomize
[g2:j2].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End Sub
Nhấp chuột vào đây để mở rộng...
dạ cảm ơn anh nhiều !
 
Upvote 0
Chép theo bên mảng kết quả thì là 1 vòng lặp.

soCanChep = 0
i2 = 0 ' đếm mảng source
For i = 1 To dongCuoi ' chép mảng kết quả
If i >= soCanChep Then
soChep = 0
i2 = i2 + 1
soCanChep = soCanChep + a(i2, 2)
End If
b(i, 1) = a(i2, 1)
b(i, 2) = 1
b(i, 3 = a(i2, 3)
b(i, 4) = a(i2, 4)
Next i
 
Upvote 0
VetMini đã viết:
Chép theo bên mảng kết quả thì là 1 vòng lặp.

soCanChep = 0
i2 = 0 ' đếm mảng source
For i = 1 To dongCuoi ' chép mảng kết quả
If i >= soCanChep Then
soChep = 0
i2 = i2 + 1
soCanChep = soCanChep + a(i2, 2)
End If
b(i, 1) = a(i2, 1)
b(i, 2) = 1
b(i, 3 = a(i2, 3)
b(i, 4) = a(i2, 4)
Next i
Nhấp chuột vào đây để mở rộng...
bạn giúp cho người ta thì giúp cho đàng hoàng, viết code cho rõ ràng đầy đủ lại được không. chứ mình thử thì không đúng cú pháp
1587197471812.png
 
Upvote 0
hunglam123 đã viết:
bạn giúp cho người ta thì giúp cho đàng hoàng, viết code cho rõ ràng đầy đủ lại được không. chứ mình thử thì không đúng cú pháp
...
Nhấp chuột vào đây để mở rộng...
Chi vậy? Code chỉ dùng để diễn tả thuật toán theo câu hỏi bài #4. Đâu có giúp ai đâu.
 
Upvote 0
Ủa, mình nhớ bài #4 hình như mình có trích dẫn bài viết của bác SA_DêQuáXá mà ta
 
Upvote 0
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Có khi nào "DATA BAN ĐẦU" Tên hàng có nhiều mặt hàng giống nhau không bạn, ví dụ bánh chưng lần1=1 lần 2=3 => Tổng 2 lần = 4
Như vậy "DATA MONG MUỐN" phải 4 dòng?
Nhấp chuột vào đây để mở rộng...

OT đang học Dictionary nên hỏi trường hợp này và cũng code thử xem thế nào, thấy code cũng chạy được và cũng cho ra kết quả:
Mã: 
Sub Tac_Dong()

    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
  
    Dim Vao As Variant, Ra As Variant, sh As Worksheet
    Dim Key As String, iKey As Integer
    Dim I As Long, R As Long, K As Long, J As Long
  
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    R = sh.Cells(sh.Rows.Count, "B").End(xlUp).Row
    If R < 3 Then Exit Sub
    Vao = sh.Range("B3:E" & R).Value
    R = WorksheetFunction.Sum(sh.Range("C3:C" & R))
    ReDim Ra(1 To R, 1 To 4)
  
    For I = 1 To UBound(Vao)
        Key = Vao(I, 1): iKey = Vao(I, 2)
        If Key <> Empty Then
            If Not Dic.Exists(Key) Then
                Dic.Add Key, iKey
            Else
                Dic(Key) = Dic.Item(Key) + iKey
            End If
            For J = 1 To iKey
                K = K + 1
                Ra(K, 1) = Key
                Ra(K, 2) = iKey / iKey
                Ra(K, 3) = Vao(I, 3)
                Ra(K, 4) = Vao(I, 4)
            Next J
        End If
    Next I
  
    sh.Range("G3").Resize(10000, 4).ClearContents
    sh.Range("G3").Resize(R, 4).Value = Ra
  
End Sub
 
Upvote 0
Có khi nào "DATA BAN ĐẦU" Tên hàng có nhiều mặt hàng giống nhau không bạn, ví dụ bánh chưng lần1=1 lần 2=3 => Tổng 2 lần = 4
Như vậy "DATA MONG MUỐN" phải 4 dòng?
Nhấp chuột vào đây để mở rộng...
Thì cũng có tất thẩy 4 dòng thôi, tuy không nằm gần nhau giữa các dòng cùng mã hàng; Nhưng đó là đang zản cách XH nhằm chống Covid19 mà!
Bài đã được tự động gộp:

Nguyễn Hoàng Oanh Thơ đã viết:
OT đang học Dictionary nên hỏi trường hợp này và cũng code thử xem thế nào, thấy code cũng chạy được và cũng cho ra kết quả:
Nhấp chuột vào đây để mở rộng...
Tuyệt vời! Nhưng nếu khong xài Dict thì có làm thế này không vậy:

DATA BAN ĐẦUDATA MONG MUỐN
Tên hàngSLĐơn giáGhi chúTên hàngSLĐơn giáGhi chú
Bánh ít
3​
2000​
Ít gaiBánh ít
1​
2000​
Ít gai
Bánh chưng
1​
5000​
Bánh ít
1​
2000​
Ít gai
Bánh tét
4​
6000​
Ít nhânBánh ít
1​
2000​
Ít gai
Thịt chó
1​
7000​
Bánh ít
1​
2000​
Ít gai
Bánh ít
2​
2000​
Ít gai |==>Bánh ít
1​
2000​
Ít gai
Bánh chưng
1​
5000​
Bánh tét
1​
6000​
Ít nhân
Bánh tét
1​
6000​
Ít nhân
Bánh tét
1​
6000​
Ít nhân
Bánh tét
1​
6000​
Ít nhân
Thịt chó
1​
7000​

PHP: 
Sub DonDongVoiHon1MatHang()
 Dim Rng As Range, sRng As Range, WF As Object, Cls As Range
 Dim MyAdd As String, TenHH As String
 Dim J As Long, W As Integer, SoLg As Long, Dm As Integer, Dg As Integer, Rws As Long
 
 Rws = [B2].CurrentRegion.Rows.Count:           Set WF = Application.WorksheetFunction
 SoLg = WF.Sum([C3].Resize(Rws)):                   TenHH = "GPE.COM"
 ReDim Arr(1 To SoLg, 1 To 4):                      [G3].Resize(9 + SoLg, 4).Value = ""
 Set Rng = [B2].Resize(Rws)
 For Each Cls In Range([B3], [B3].End(xlDown))
    If InStr(TenHH, Cls.Value) < 1 Then
        TenHH = Cls.Value & TenHH
         Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            MyAdd = sRng.Address
            Do
                For Dg = 1 To sRng.Offset(, 1).Value
                    W = W + 1:                                  Arr(W, 1) = Cls.Value
                    Arr(W, 2) = 1:                              Arr(W, 3) = sRng.Offset(, 2).Value
                    Arr(W, 4) = sRng.Offset(, 3).Value
                Next Dg
                Set sRng = Rng.FindNext(sRng)
            Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        End If
    End If
 Next Cls
 [G3].Resize(W, 4).Value = Arr()
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
SA_DQ đã viết:
Thì cũng có tất thẩy 4 dòng thôi, tuy không nằm gần nhau giữa các dòng cùng mã hàng; Nhưng đó là đang zản cách XH nhằm chống Covid19 mà!
Bài đã được tự động gộp:


Tuyệt vời! Nhưng nếu khong xài Dict thì có làm thế này không vậy:

DATA BAN ĐẦUDATA MONG MUỐN
Tên hàngSLĐơn giáGhi chúTên hàngSLĐơn giáGhi chú
Bánh ít
3​
2000​
Ít gaiBánh ít
1​
2000​
Ít gai
Bánh chưng
1​
5000​
Bánh ít
1​
2000​
Ít gai
Bánh tét
4​
6000​
Ít nhânBánh ít
1​
2000​
Ít gai
Thịt chó
1​
7000​
Bánh ít
1​
2000​
Ít gai
Bánh ít
2​
2000​
Ít gai |==>Bánh ít
1​
2000​
Ít gai
Bánh chưng
1​
5000​
Bánh tét
1​
6000​
Ít nhân
Bánh tét
1​
6000​
Ít nhân
Bánh tét
1​
6000​
Ít nhân
Bánh tét
1​
6000​
Ít nhân
Thịt chó
1​
7000​
Nhấp chuột vào đây để mở rộng...

Con chào Bác SA_DQ, ủa con chạy code của Bác con thấy kết quả y chang kết quả của Bác rồi mà.
 
Upvote 0
Nếu vậy chỉ cần thêm một câu lệnh sắp theo mã hàng sau khi đập kết quả từ mảng xuống sheet là được ạ.
Nhấp chuột vào đây để mở rộng...
Vấn đề là không dùng Dictionary kia nha. & xem xếp luôn trong mảng được không?
 
Lần chỉnh sửa cuối:
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
OT đang học Dictionary nên hỏi trường hợp này và cũng code thử xem thế nào, thấy code cũng chạy được và cũng cho ra kết quả:
Mã: 
Sub Tac_Dong()

    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
 
    Dim Vao As Variant, Ra As Variant, sh As Worksheet
    Dim Key As String, iKey As Integer
    Dim I As Long, R As Long, K As Long, J As Long
 
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    R = sh.Cells(sh.Rows.Count, "B").End(xlUp).Row
    If R < 3 Then Exit Sub
    Vao = sh.Range("B3:E" & R).Value
    R = WorksheetFunction.Sum(sh.Range("C3:C" & R))
    ReDim Ra(1 To R, 1 To 4)
 
    For I = 1 To UBound(Vao)
        Key = Vao(I, 1): iKey = Vao(I, 2)
        If Key <> Empty Then
            If Not Dic.Exists(Key) Then
                Dic.Add Key, iKey
            Else
                Dic(Key) = Dic.Item(Key) + iKey
            End If
            For J = 1 To iKey
                K = K + 1
                Ra(K, 1) = Key
                Ra(K, 2) = iKey / iKey
                Ra(K, 3) = Vao(I, 3)
                Ra(K, 4) = Vao(I, 4)
            Next J
        End If
    Next I
 
    sh.Range("G3").Resize(10000, 4).ClearContents
    sh.Range("G3").Resize(R, 4).Value = Ra
 
End Sub
Nhấp chuột vào đây để mở rộng...
Lạ quá, thử xóa dic kết quả vẫn không đổi
 
Upvote 0
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Lạ quá, thử xóa dic kết quả vẫn không đổi
Nhấp chuột vào đây để mở rộng...
Bác ơi, Bác chỉ giúp con cách làm để liên quan đến Dic và sắp xếp dữ liệu giống dạng bài 17 với ạ, con loay hoay mãi mà chưa làm được ạ.
www.giaiphapexcel.com

Mọi người giúp mình tách tên hàng theo từng số lượng

Chào các anh chị diễn đàn PGE . Em cần tách 1 vùng như hình đính kèm bên dưới. nhờ mọi người. xin chân thành cảm ơn
www.giaiphapexcel.com www.giaiphapexcel.com
 
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
Bác ơi, Bác chỉ giúp con cách làm để liên quan đến Dic và sắp xếp dữ liệu giống dạng bài 17 với ạ, con loay hoay mãi mà chưa làm được ạ.
www.giaiphapexcel.com

Mọi người giúp mình tách tên hàng theo từng số lượng

Chào các anh chị diễn đàn PGE . Em cần tách 1 vùng như hình đính kèm bên dưới. nhờ mọi người. xin chân thành cảm ơn
www.giaiphapexcel.com www.giaiphapexcel.com
Nhấp chuột vào đây để mở rộng...
Chạy code
Mã: 
Sub XYZ()
  Dim sArr(), tArr, Res(), Dic As Object
  Dim sRow&, i&, N&, k&, ik&
 
  With Sheets("Sheet1")
    i = .Range("G" & .Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("G3:J" & i).ClearContents
    i = .Range("B" & .Rows.Count).End(xlUp).Row
    If i < 3 Then Exit Sub
    sArr = .Range("B3:E" & i).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArr)
    sRow = sRow + sArr(i, 2)
    Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & i
  Next i
  ReDim Res(1 To sRow, 1 To 4)
  tArr = Split(Join(Dic.items), ",")
  For i = 1 To sRow
    If i > N Then
      k = k + 1
      ik = tArr(k)
      N = N + sArr(ik, 2)
    End If
    Res(i, 1) = sArr(ik, 1):  Res(i, 2) = 1
    Res(i, 3) = sArr(ik, 3):  Res(i, 4) = sArr(ik, 4)
  Next i
  If k Then Sheets("Sheet1").Range("G3").Resize(sRow, 4).Value = Res
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy code
Mã: 
Sub XYZ()
  Dim sArr(), tArr, Res(), Dic As Object
  Dim sRow&, i&, N&, k&, ik&

  With Sheets("Sheet1")
    i = .Range("G" & .Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("G3:J" & i).ClearContents
    i = .Range("B" & .Rows.Count).End(xlUp).Row
    If i < 3 Then Exit Sub
    sArr = .Range("B3:E" & i).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArr)
    sRow = sRow + sArr(i, 2)
    Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & i
  Next i
  ReDim Res(1 To sRow, 1 To 4)
  tArr = Split(Join(Dic.items), ",")
  For i = 1 To sRow
    If i > N Then
      k = k + 1
      ik = tArr(k)
      N = N + sArr(ik, 2)
    End If
    Res(i, 1) = sArr(ik, 1):  Res(i, 2) = 1
    Res(i, 3) = sArr(ik, 3):  Res(i, 4) = sArr(ik, 4)
  Next i
  If k Then Sheets("Sheet1").Range("G3").Resize(sRow, 4).Value = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Nhờ Anh có thể chú thích code được không Anh? Em đọc mà chưa hiểu lắm. Cảm ơn Anh rất nhiều.
 
Upvote 0
HieuCD đã viết:
Chạy code
Mã: 
Sub XYZ()
  Dim sArr(), tArr, Res(), Dic As Object
  Dim sRow&, i&, N&, k&, ik&

  With Sheets("Sheet1")
    i = .Range("G" & .Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("G3:J" & i).ClearContents
    i = .Range("B" & .Rows.Count).End(xlUp).Row
    If i < 3 Then Exit Sub
    sArr = .Range("B3:E" & i).Value
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArr)
    sRow = sRow + sArr(i, 2)
    Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & i
  Next i
  ReDim Res(1 To sRow, 1 To 4)
  tArr = Split(Join(Dic.items), ",")
  For i = 1 To sRow
    If i > N Then
      k = k + 1
      ik = tArr(k)
      N = N + sArr(ik, 2)
    End If
    Res(i, 1) = sArr(ik, 1):  Res(i, 2) = 1
    Res(i, 3) = sArr(ik, 3):  Res(i, 4) = sArr(ik, 4)
  Next i
  If k Then Sheets("Sheet1").Range("G3").Resize(sRow, 4).Value = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Code này đã thông qua trường hợp sau?
Nếu một món hàng có thể lặp lại nhiều lần trong bảng cái thì nó cũng có khả năng có đơn giá, và ghi chú khác.
 
Upvote 0
VetMini đã viết:
Code này đã thông qua trường hợp sau?
Nếu một món hàng có thể lặp lại nhiều lần trong bảng cái thì nó cũng có khả năng có đơn giá, và ghi chú khác.
Nhấp chuột vào đây để mở rộng...
Code nầy của bạn mờ, chỉ dùng dic để kéo các tên hàng nằm lạc chổ lại gần nhau thôi
 
Upvote 0
huonglien1901 đã viết:
Nhờ Anh có thể chú thích code được không Anh? Em đọc mà chưa hiểu lắm. Cảm ơn Anh rất nhiều.
Nhấp chuột vào đây để mở rộng...
Code qua nhiều bước khá phức tạp
Mã: 
Sub XYZ()
  Dim sArr(), tArr, Res(), Dic As Object
  Dim sRow&, i&, N&, k&, ik&
 
  With Sheets("Sheet1")
    i = .Range("G" & .Rows.Count).End(xlUp).Row 'Dòng cuoi bang ket qua
    If i > 2 Then .Range("G3:J" & i).ClearContents 'Xóa bang ket qua
    i = .Range("B" & .Rows.Count).End(xlUp).Row 'Dòng cuoi vùng du lieu
    If i < 3 Then Exit Sub 'Khong co du lieu thoat sub
    sArr = .Range("B3:E" & i).Value ' mang du lieu
  End With
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArr)
    sRow = sRow + sArr(i, 2) 'Tinh so dòng ket qua
    Dic.Item(sArr(i, 1)) = Dic.Item(sArr(i, 1)) & "," & i 'Ghep thu tu dong cua ten hang giong nhau
  Next i
  ReDim Res(1 To sRow, 1 To 4)
  tArr = Split(Join(Dic.items), ",") 'Mang thu tu dòng du lieu, voi thu tu dong cua 1 ten hang nam ke nhau
  For i = 1 To sRow
    If i > N Then 'Neu dòng ket qua vuot qua tan so tich luy cua San Luong theo tung dòng du lieu
      k = k + 1 'Chi so dong du lieu ke sau, cua mang du lieu
      ik = tArr(k) ' Thu tu dong ke sau cua mang du lieu
      N = N + sArr(ik, 2) ' Tinh tan so tich luy cua dòng moi
    End If
    Res(i, 1) = sArr(ik, 1):  Res(i, 2) = 1 ' Gan dòng ket qua "i" theo thu tu dòng "ik" cua mang du lieu
    Res(i, 3) = sArr(ik, 3):  Res(i, 4) = sArr(ik, 4)
  Next i
  If k Then Sheets("Sheet1").Range("G3").Resize(sRow, 4).Value = Res
End Sub
 
Upvote 0
SA_DQ đã viết:
Mình 'tìm' giúp cho bạn nè, mại zô.
PHP: 
Sub TaoBangVoiSoLuongBang1()
Dim J As Long, W As Integer, SoLg As Long, Dem As Integer, Dg As Integer
Dim Arr(), WF As Object

Arr() = [C3].CurrentRegion.Offset(2).Value
Set WF = Application.WorksheetFunction
SoLg = WF.Sum([C3].Resize(UBound(Arr())))
ReDim dArr(1 To SoLg, 1 To 4):       [G3].Resize(9 + SoLg, 4).Value = ""
For J = 1 To UBound(Arr())
    If Arr(J, 2) = "" Then Exit For
    For Dg = 1 To Arr(J, 2)
        W = W + 1
        dArr(W, 1) = Arr(J, 1):             dArr(W, 2) = 1
        dArr(W, 3) = Arr(J, 3):             dArr(W, 4) = Arr(J, 4)
    Next Dg
Next J
[G3].Resize(W, 4).Value = dArr():      Randomize
[g2:j2].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End Sub
Nhấp chuột vào đây để mở rộng...
cái này record macro cũng được mà bác
PHP: 
Sub Macro1()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheet1.Range("G3:J65536").Clear
Dim i As Long, j As Long

For i = 1 To Sheet1.Range("B1").CurrentRegion.Rows.Count - 2
  j = Sheet1.Range("C2").Offset(i).Value
   Sheet1.Range("B2:E2").Offset(i).Copy
    Sheet1.Range("G65536").End(xlUp).Offset(1).Resize(j, 4).PasteSpecial (12)
    Application.CutCopyMode = False
    Next
    Sheet1.Range("H3:H" & Sheet1.Range("H65536").End(xlUp).Row).Value = 1
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
chào cả nhà!
trong trường hợp mình muốn tách qua sheet khác thì code như thế nào
mong cả nhà giúp dùm !!!
 
Upvote 0
VUDER đã viết:
cám ơn bạn
nhưng mình muốn chạy code thì phải làm sao
Nhấp chuột vào đây để mở rộng...

code đây. thay đổi thông số ở cột "real qty " sheet1 và xem KQ ở sheet2.
Mã: 
Private Sub Worksheet_Activate()
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheet2.Range("a2:J65536").Clear
Dim i As Long, j As Long

For i = 1 To Sheet1.Range("A1").CurrentRegion.Rows.Count - 1
  j = Sheet1.Range("d1").Offset(i).Value
   Sheet1.Range("a1:d1").Offset(i).Copy
    Sheet2.Range("a65536").End(xlUp).Offset(1).Resize(j, 4).PasteSpecial (12)
    Application.CutCopyMode = False
    Next
    Sheet2.Range("d2:d" & Sheet2.Range("d65536").End(xlUp).Row).Value = 1
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 

File đính kèm

Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

hongphuong1997
Nên sử dụng Chatgpt hay Copilot (1 người xem)
    • Yêu thích
Trả lời
4
Đọc
140
PhanTuHuong
PhanTuHuong
L
Xin file lịch báo giảng tự động
Trả lời
2
Đọc
66
linedraw84
L
H
Xin File Theo dõi công nợ
Trả lời
0
Đọc
41
HangktGTN
H
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD (1 người xem)
    • Thích
Trả lời
16
Đọc
987
linedraw84
L
N
Tạo file Excel dùng VBA để lấy và nối dữ liệu từ các files excel
Trả lời
39
Đọc
6K
hungnv_thct2026
H
S
Power BI. Một quá trình đòi hỏi sự kiên nhẫn.
Trả lời
4
Đọc
186
SteveNguyen1991
S
SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ!
    • Ngạc nhiên
    • Cười
    • Yêu thích
Trả lời
21
Đọc
718
Phuocam
Phuocam
H
Giúp mình ghép nhiều file thành một file.
Trả lời
9
Đọc
334
Hoàng Tuấn 868
H
H
  • Question Question
Dò tìm giá trị từ bảng khác theo cột
Trả lời
5
Đọc
105
ptm0412
ptm0412
L
Cách bật/tắt đèn led thứ 3 trên bàn phím cơ
Trả lời
1
Đọc
63
HUONGHCKT
H
C
Không thể group cột trong excel (1 người xem)
Trả lời
10
Đọc
12K
ptm0412
ptm0412
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
14
Đọc
990
Hoàng Tuấn 868
H
H
Xin giúp đỡ về phổ cập
Trả lời
5
Đọc
997
tranvanky8111967
T
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
420
Đọc
52K
maingoctu89
M
P
Xin giúp sửa code VBA tổng hợp sản lượng theo format file FCS đổ từ hệ thống ERP.
Trả lời
14
Đọc
306
DeTong
D
L
Nhờ anh chị giúp đỡ công thức hàm len
Trả lời
44
Đọc
763
khuong182018
khuong182018
hongphuong1997
Cách tô màu một dòng theo chiều cao tùy ý
Trả lời
5
Đọc
203
hongphuong1997
hongphuong1997
D
nhờ anh chị giải thích hàm hstack
Trả lời
2
Đọc
152
dungpham01
D
L
Nhờ anh chị giúp giúp đỡ hàm ạ
    • Chấp nhận
Trả lời
12
Đọc
376
Phan Thế Hiệp
Phan Thế Hiệp
vuthaiha90
Lọc dữ liệu không trùng và trả kết quả về 1 dòng
Trả lời
6
Đọc
202
Duy Tùng 9x
Duy Tùng 9x
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom