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

hunglam123 · 18/4/20

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

VetMini · 18/4/20

Code này có cả đống rồi. Chịu khó mà tìm.

SA_DQ · 18/4/20

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

concogia · 18/4/20

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

Tui muốn....1 vòng lặp "thui". Được hông ?????

hunglam123 · 18/4/20

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

dạ cảm ơn anh nhiều !

VetMini · 18/4/20

concogia đã viết:
Tui muốn....1 vòng lặp "thui". Được hông ?????

Chi vậy? 1 vòng lặp có giảm được số con tính hôn?
Bài này đáng lẽ phải thấy 3 vòng lặp. Người ta đã tự giảm hết 1 rồi.

concogia · 18/4/20

VetMini đã viết:
Chi vậy? 1 vòng lặp có giảm được số con tính hôn?
Bài này đáng lẽ phải thấy 3 vòng lặp. Người ta đã tự giảm hết 1 rồi.

Bài này chính xác là 2 vòng lặp, còn 1 vòng là vui chơi thôi chứ có chi đâu, cò 3 vòng thì ....không biết

VetMini · 18/4/20

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

hunglam123 · 18/4/20

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

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

VetMini · 18/4/20

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
...

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.

concogia · 18/4/20

Ủ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

Hoàng Nhật Phương · 18/4/20

hunglam123 đã viết:
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
View attachment 235905

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?

PacificPR · 18/4/20

Có người mua nửa cái bánh chưng thì tách làm sao

CHAOQUAY · 18/4/20

PacificPR đã viết:
Có người mua nửa cái bánh chưng thì tách làm sao

Có lẽ họ sẽ gọi bạn tới mua nửa còn lại

PacificPR · 18/4/20

CHAOQUAY đã viết:
Có lẽ họ sẽ gọi bạn tới mua nửa còn lại

Em mà mua chỉ mua 1/4 cái thôi. Nửa cái ăn không hết

Hoàng Nhật Phương · 18/4/20

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?

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

SA_DQ · 18/4/20

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?

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: 18/4/20

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ả:

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 ĐẦU					DATA MONG MUỐN
Tên hàng	SL	Đơn giá	Ghi chú		Tên hàng	SL	Đơn giá	Ghi chú
*Bánh ít*	3	2000	Ít gai		Bá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ân		Bá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

Hoàng Nhật Phương · 18/4/20

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: 18/4/20

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 ĐẦU DATA MONG MUỐN
Tên hàng SL Đơn giá Ghi chú Tên hàng SL Đơn giá Ghi chú
Bánh ít
3
2000
Ít gai Bá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ân Bá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

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à.

SA_DQ · 18/4/20

. . . ủ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à.

Nếu có 2 dòng bánh ít ở 2 dòng xa nhau thì chưa theo iêu cầu dồn các dòng cùng loại hàng lại với nhau đâu.

Hoàng Nhật Phương · 18/4/20

SA_DQ đã viết:
Nếu có 2 dòng bánh ít ở 2 dòng xa nhau thì chưa theo iêu cầu dồn các dòng cùng loại hàng lại với nhau đâu.

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 ạ.

SA_DQ · 18/4/20

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 ạ.

Vấn đề là không dùng Dictionary kia nha. & xem xếp luôn trong mảng được không?

HieuCD · 18/4/20

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

Lạ quá, thử xóa dic kết quả vẫn không đổi

Hoàng Nhật Phương · 18/4/20

SA_DQ đã viết:
Vấn đề là không dùng Dictionary kia nha. & xem xếp luôn trong mảng được không?

HieuCD đã viết:
Lạ quá, thử xóa dic kết quả vẫn không đổi

,Hic con biết ngay là con conde mày chạy êm ru và ra kết quả thế này là đã có cái gì đó sai sai rồi mà.
Vâng mùa covid ở nhà,con sẽ cố gắng nghiên cứu thêm ạ.

Hoàng Nhật Phương · 19/4/20

HieuCD đã viết:
Lạ quá, thử xóa dic kết quả vẫn không đổi

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 ạ.

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

HieuCD · 19/4/20

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 ạ.

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

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

huonglien1901 · 19/4/20

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ờ 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.

VetMini · 19/4/20

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

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.

HieuCD · 19/4/20

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.

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

HieuCD · 19/4/20

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.

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

Lê Duy Thương · 22/4/20

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

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

VUDER · 10/11/20

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 !!!

Lê Duy Thương · 10/11/20

VUDER đã viết:
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 !!!

Cần có file mẫu nhé bạn. hỏi chung chung khó trả lời lắm

VUDER · 10/11/20

mình gửi file mẫu, mong cả nhà giúp ạ

hocexcel_1991 · 10/11/20

VUDER đã viết:
mình gửi file mẫu, mong cả nhà giúp ạ

Xem file đính kèm

VUDER · 10/11/20

hocexcel_1991 đã viết:
Xem file đính kèm

cám ơn bạn
nhưng mình muốn chạy code thì phải làm sao

hocexcel_1991 · 10/11/20

VUDER đã viết:
cám ơn bạn
nhưng mình muốn chạy code thì phải làm sao

Code thì chờ các thành viên khác giúp nhé, mình "mù tịt" món này

HieuCD · 11/11/20

hocexcel_1991 đã viết:
Code thì chờ các thành viên khác giúp nhé, mình "mù tịt" món này

Học từ từ sẽ biết

be_09 · 11/11/20

VUDER đã viết:
mình gửi file mẫu, mong cả nhà giúp ạ

Làm như kiểu bạn chắc phải bán nhà để đền (so sánh số lượng của 2 sheet để hiểu?)..

Trần Nhật Anh · 11/11/20

VUDER đã viết:
cám ơn bạn
nhưng mình muốn chạy code thì phải làm sao

Thay đổi sheet1 mở sheet2 có kết quả

Lê Duy Thương · 11/11/20

VUDER đã viết:
cám ơn bạn
nhưng mình muốn chạy code thì phải làm sao

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

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

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

Thành viên bị đình chỉ hoạt động

File đính kèm

Đang đi tìm hòn đá

/(hông là gì!

Gội rồi mới Cạo

Thành viên bị đình chỉ hoạt động

Đang đi tìm hòn đá

Gội rồi mới Cạo

Đang đi tìm hòn đá

Thành viên bị đình chỉ hoạt động

Đang đi tìm hòn đá

Gội rồi mới Cạo

Thành viên gắn bó

Thành viên mới

Thành viên gắn bó

Thành viên mới

Thành viên gắn bó

/(hông là gì!

Thành viên gắn bó

/(hông là gì!

Thành viên gắn bó

/(hông là gì!

Chuyên gia GPE

Thành viên gắn bó

Thành viên gắn bó

Chuyên gia GPE

GPE là ngôi nhà thứ 2 của tôi!!!

Đang đi tìm hòn đá

Chuyên gia GPE

Chuyên gia GPE

Cạo lấy gì gội (Dịch quá không gội được)

Thành viên mới

Cạo lấy gì gội (Dịch quá không gội được)

Thành viên mới

File đính kèm

Bắt đầu học Excel

File đính kèm

Thành viên mới

Bắt đầu học Excel

Chuyên gia GPE

Biên Hòa, Đồng Nai

Thành viên mới

File đính kèm

Cạo lấy gì gội (Dịch quá không gội được)

File đính kèm

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