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

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

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

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

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

File đính kèm

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

Ăn cùng góc phố

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