Tách dòng tự động trong Excel (số lượng dòng tách tham chiếu theo cột mã hàng và Số lượng)

Liên hệ QC
K

khkkh

Thành viên mới
Tham gia
29/5/12
Bài viết
37
Được thích
1
Chào cả nhà
Hôm nay mình lại đang vật lộn với bài toán khó
Mình có 1 bảng dữ liệu thống kê hàng xuất, mình muốn trình bày lại bảng này theo định dạng tách dòng theo cột mã hàng và số lượng. (Mình tách thủ công nên mất khá nhiều thời gian và có thể sai sót khi dữ liệu nhiều ; mong các cao thủ và tiền bối ra tay giúp)
mọi người xem file gửi kèm và giúp đỡ nhé
Xin cảm ơn
 

File đính kèm

  • Tách dữ liệu.xls
    25 KB · Đọc: 37
Sắp xếp theo thời gian sắp xếp theo bầu chọn
SEAHAI đã viết:
Chào cả nhà
Hôm nay mình lại đang vật lộn với bài toán khó
Mình có 1 bảng dữ liệu thống kê hàng xuất, mình muốn trình bày lại bảng này theo định dạng tách dòng theo cột mã hàng và số lượng. (Mình tách thủ công nên mất khá nhiều thời gian và có thể sai sót khi dữ liệu nhiều ; mong các cao thủ và tiền bối ra tay giúp)
mọi người xem file gửi kèm và giúp đỡ nhé
Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Thử cái này
Mã: 
Sub abc()
Dim Nguon
Dim Kq
Dim Gh
Dim i, j, k, x
Nguon = Sheet2.Range("A2:C9")
ReDim Kq(1 To 1000, 1 To 4)
For i = 1 To UBound(Nguon)
    If Nguon(i, 2) = "MH A" Or Nguon(i, 2) = "MH C" Then
        Gh = 5
    Else
        Gh = 4
    End If
    k = Nguon(i, 3)
    Do While k >= Gh
        j = j + 1
        Kq(j, 2) = Nguon(i, 1)
        Kq(j, 3) = Nguon(i, 2)
        Kq(j, 4) = Gh
        k = k - Gh
    Loop
    If k Then
        If Gh = 5 Then
            j = j + 1
            Kq(j, 2) = Nguon(i, 1)
            Kq(j, 3) = Nguon(i, 2)
            Kq(j, 4) = k
        Else
            For x = j + 1 To j + k
                Kq(x, 2) = Nguon(i, 1)
                Kq(x, 3) = Nguon(i, 2)
                Kq(x, 4) = 1
            Next x
            j = j + k
        End If
    End If
Next i
With Sheet3
    .Range("A2").Resize(1000, 4).Clear
    .Range("A2").Resize(j, 4) = Kq
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:= _
        .Range("D2:D" & j + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    .Sort.SetRange Range("A1:D" & j + 1)
    .Sort.Header = xlYes
    .Sort.MatchCase = False
    .Sort.Orientation = xlTopToBottom
    .Sort.SortMethod = xlPinYin
    .Sort.Apply
    .Range("A2:A" & j + 1) = "=row()-1"
End With
End Sub
 
Upvote 0
Thanks bạn, bạn ơi có thể gởi cho mình file để mình xem cho dễ hiểu không thanks nhiều
Bài đã được tự động gộp:

Thanks bạn, bạn ơi có thể gởi cho mình file excel được không thanks bạn
 
Upvote 0

File đính kèm

  • Copy of Tách dữ liệu-1.xls
    47.5 KB · Đọc: 35
Upvote 0
Sao không hỏi luôn video chỉ dẫn cách chạy code?
 
Upvote 0
CHAOQUAY đã viết:
Thử cái này
Mã: 
Sub abc()
Dim Nguon
Dim Kq
Dim Gh
Dim i, j, k, x
Nguon = Sheet2.Range("A2:C9")
ReDim Kq(1 To 1000, 1 To 4)
For i = 1 To UBound(Nguon)
    If Nguon(i, 2) = "MH A" Or Nguon(i, 2) = "MH C" Then
        Gh = 5
    Else
        Gh = 4
    End If
    k = Nguon(i, 3)
    Do While k >= Gh
        j = j + 1
        Kq(j, 2) = Nguon(i, 1)
        Kq(j, 3) = Nguon(i, 2)
        Kq(j, 4) = Gh
        k = k - Gh
    Loop
    If k Then
        If Gh = 5 Then
            j = j + 1
            Kq(j, 2) = Nguon(i, 1)
            Kq(j, 3) = Nguon(i, 2)
            Kq(j, 4) = k
        Else
            For x = j + 1 To j + k
                Kq(x, 2) = Nguon(i, 1)
                Kq(x, 3) = Nguon(i, 2)
                Kq(x, 4) = 1
            Next x
            j = j + k
        End If
    End If
Next i
With Sheet3
    .Range("A2").Resize(1000, 4).Clear
    .Range("A2").Resize(j, 4) = Kq
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:= _
        .Range("D2:D" & j + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    .Sort.SetRange Range("A1:D" & j + 1)
    .Sort.Header = xlYes
    .Sort.MatchCase = False
    .Sort.Orientation = xlTopToBottom
    .Sort.SortMethod = xlPinYin
    .Sort.Apply
    .Range("A2:A" & j + 1) = "=row()-1"
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn ơi xem và giúp mình file này với (File bữa ít dữ liệu nên khi sang file mới này nhiều dữ liệu mò không ra)
giúp mình với nhé .
Thanks
Bài đã được tự động gộp:

VetMini đã viết:
Sao không hỏi luôn video chỉ dẫn cách chạy code?
Nhấp chuột vào đây để mở rộng...
ừ nhỉ-- quên:D
 

File đính kèm

  • Tach Drop shipment.xls
    74.5 KB · Đọc: 16
Upvote 0
SEAHAI đã viết:
Bạn cho mình xin file bạn đã làm.
Nếu có video hướng dẫn càng tốt(vba mình gà )
Cảm ơn
Nhấp chuột vào đây để mở rộng...
Chạy đoạn code dưới đây cho file bài 7.
Để chép code vào file, có lẽ bạn tìm trên diễn đàn cho chủ động.
Mã: 
Sub a_abc()
Dim Nguon
Dim MHA, MHB
Dim Kq
Dim Gh
Dim i, j, k, x, z, t
Dim rws As Long, cls As Long
Nguon = Sheet2.Range("A2", Sheet2.Range("Q65000").End(xlUp))
rws = UBound(Nguon)
cls = UBound(Nguon, 2)
ReDim Kq(1 To rws * 10, 1 To cls)

MHA = "42711K01902"
MHB = "42711k56V01"
For i = 1 To rws
    If Nguon(i, 8) = MHA Or Nguon(i, 8) = MHB Then
        Gh = 5
    Else
        Gh = 4
    End If
    k = Nguon(i, cls)
    Do While k >= Gh
        x = x + 1
        Kq(x, cls) = Gh
        For z = 1 To cls - 1
            Kq(x, z) = Nguon(i, z)
        Next z
        k = k - Gh
    Loop
    If k Then
        If Gh = 5 Then
            x = x + 1
            Kq(x, cls) = Gh
            For z = 1 To cls - 1
                Kq(x, z) = Nguon(i, z)
            Next z
        Else
            For j = x + 1 To x + k
                Kq(j, cls) = 1
                For z = 1 To cls - 1
                    Kq(j, z) = Nguon(i, z)
                Next z
            Next j
            x = x + k
        End If
    End If
Next i
With Sheet3
    .Range("A2").Resize(1000, cls).Clear
    .Range("A2").Resize(x, cls) = Kq
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:= _
        .Range("Q2:Q" & x + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    .Sort.SetRange Range("A1:Q" & x + 1)
    .Sort.Header = xlYes
    .Sort.MatchCase = False
    .Sort.Orientation = xlTopToBottom
    .Sort.SortMethod = xlPinYin
    .Sort.Apply
    .UsedRange.Columns.AutoFit
End With
End Sub
 
Upvote 0
BT1920 đã viết:
Mình ham vui tải về để học hỏi ạ, nó bị lỗi chỗ này, nếu bạn có thời gian và không phiền thì bạn xem thử lại lỗi này do máy mình hay sao ạ?
View attachment 235588
Nhấp chuột vào đây để mở rộng...
Xem lại tại đây nhé bạn.
CHAOQUAY đã viết:
Chạy đoạn code dưới đây cho file bài 7.
Để chép code vào file, có lẽ bạn tìm trên diễn đàn cho chủ động.
Mã: 
Sub a_abc()
...End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
mình đã copy đoạn code ở #10 và dán vào module của file #7, cũng đã đổi định dạng file sang xlsb rồi nhưng không ăn thua nên mình gửi ảnh bạn xem đó. Mình gửi file đính kèm để dễ theo dõi ạ.
 

File đính kèm

  • Tach Drop shipment.xlsb
    34.3 KB · Đọc: 9
Upvote 0
CHAOQUAY đã viết:
Chạy đoạn code dưới đây cho file bài 7.
Để chép code vào file, có lẽ bạn tìm trên diễn đàn cho chủ động.
Mã: 
Sub a_abc()
Dim Nguon
Dim MHA, MHB
Dim Kq
Dim Gh
Dim i, j, k, x, z, t
Dim rws As Long, cls As Long
Nguon = Sheet2.Range("A2", Sheet2.Range("Q65000").End(xlUp))
rws = UBound(Nguon)
cls = UBound(Nguon, 2)
ReDim Kq(1 To rws * 10, 1 To cls)

MHA = "42711K01902"
MHB = "42711k56V01"
For i = 1 To rws
    If Nguon(i, 8) = MHA Or Nguon(i, 8) = MHB Then
        Gh = 5
    Else
        Gh = 4
    End If
    k = Nguon(i, cls)
    Do While k >= Gh
        x = x + 1
        Kq(x, cls) = Gh
        For z = 1 To cls - 1
            Kq(x, z) = Nguon(i, z)
        Next z
        k = k - Gh
    Loop
    If k Then
        If Gh = 5 Then
            x = x + 1
            Kq(x, cls) = Gh
            For z = 1 To cls - 1
                Kq(x, z) = Nguon(i, z)
            Next z
        Else
            For j = x + 1 To x + k
                Kq(j, cls) = 1
                For z = 1 To cls - 1
                    Kq(j, z) = Nguon(i, z)
                Next z
            Next j
            x = x + k
        End If
    End If
Next i
With Sheet3
    .Range("A2").Resize(1000, cls).Clear
    .Range("A2").Resize(x, cls) = Kq
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:= _
        .Range("Q2:Q" & x + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    .Sort.SetRange Range("A1:Q" & x + 1)
    .Sort.Header = xlYes
    .Sort.MatchCase = False
    .Sort.Orientation = xlTopToBottom
    .Sort.SortMethod = xlPinYin
    .Sort.Apply
    .UsedRange.Columns.AutoFit
End With
End Sub
Nhấp chuột vào đây để mở rộng...
thanks ban
 
Upvote 0
BT1920 đã viết:
mình đã copy đoạn code ở #10 và dán vào module của file #7, cũng đã đổi định dạng file sang xlsb rồi nhưng không ăn thua nên mình gửi ảnh bạn xem đó. Mình gửi file đính kèm để dễ theo dõi ạ.
Nhấp chuột vào đây để mở rộng...
Chọn sheet hiện hành là "KQ_IRV" rồi hãy chạy code.
 
Upvote 0
CHAOQUAY đã viết:
Chạy đoạn code dưới đây cho file bài 7.
Để chép code vào file, có lẽ bạn tìm trên diễn đàn cho chủ động.
Mã: 
Sub a_abc()
Dim Nguon
Dim MHA, MHB
Dim Kq
Dim Gh
Dim i, j, k, x, z, t
Dim rws As Long, cls As Long
Nguon = Sheet2.Range("A2", Sheet2.Range("Q65000").End(xlUp))
rws = UBound(Nguon)
cls = UBound(Nguon, 2)
ReDim Kq(1 To rws * 10, 1 To cls)

MHA = "42711K01902"
MHB = "42711k56V01"
For i = 1 To rws
    If Nguon(i, 8) = MHA Or Nguon(i, 8) = MHB Then
        Gh = 5
    Else
        Gh = 4
    End If
    k = Nguon(i, cls)
    Do While k >= Gh
        x = x + 1
        Kq(x, cls) = Gh
        For z = 1 To cls - 1
            Kq(x, z) = Nguon(i, z)
        Next z
        k = k - Gh
    Loop
    If k Then
        If Gh = 5 Then
            x = x + 1
            Kq(x, cls) = Gh
            For z = 1 To cls - 1
                Kq(x, z) = Nguon(i, z)
            Next z
        Else
            For j = x + 1 To x + k
                Kq(j, cls) = 1
                For z = 1 To cls - 1
                    Kq(j, z) = Nguon(i, z)
                Next z
            Next j
            x = x + k
        End If
    End If
Next i
With Sheet3
    .Range("A2").Resize(1000, cls).Clear
    .Range("A2").Resize(x, cls) = Kq
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:= _
        .Range("Q2:Q" & x + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    .Sort.SetRange Range("A1:Q" & x + 1)
    .Sort.Header = xlYes
    .Sort.MatchCase = False
    .Sort.Orientation = xlTopToBottom
    .Sort.SortMethod = xlPinYin
    .Sort.Apply
    .UsedRange.Columns.AutoFit
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn ơi xem lại giúp mình với.
-Khi chạy tách xong thì kết quả tách không như mình mong muốn + số lượng tách xong nhiều hơn số lượng gốc như mục mình note trong file(Kết quả mong muốn như phần note trong file)
-Báo lỗi khi tách xong
-Khi lưu lại báo lỗi
Bạn xem file đính kèm có gì sửa cho mình với nhé.
Thanks bạn
 

File đính kèm

  • lỖI.pptx
    332.6 KB · Đọc: 4
  • Tach_Drop shipment(F).xlsm
    60 KB · Đọc: 7
Upvote 0
SEAHAI đã viết:
Bạn ơi xem lại giúp mình với.
-Khi chạy tách xong thì kết quả tách không như mình mong muốn + số lượng tách xong nhiều hơn số lượng gốc như mục mình note trong file(Kết quả mong muốn như phần note trong file)
-Báo lỗi khi tách xong
-Khi lưu lại báo lỗi
Bạn xem file đính kèm có gì sửa cho mình với nhé.
Cảm ơn bạn
Nhấp chuột vào đây để mở rộng...
Máy tôi chạy không có lỗi gì.
Tôi dừng tại đây. Còn vấn đề gì có lẽ bạn chờ các thành viên khác hỗ trợ vậy nhé.
Thân chào!
 

File đính kèm

  • seahai.rar
    3.5 MB · Đọc: 6
Upvote 0
SEAHAI đã viết:
Bạn ơi xem và giúp mình file này với (File bữa ít dữ liệu nên khi sang file mới này nhiều dữ liệu mò không ra)
giúp mình với nhé .
Cảm ơn
Bài đã được tự động gộp:


ừ nhỉ-- quên:D
Nhấp chuột vào đây để mở rộng...
Thử code
Mã: 
Sub ABC()
  Dim sArr(), Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&

  sArr = Sheet2.Range("A2", Sheet2.Range("Q65000").End(xlUp)).Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow * 10, 1 To sCol)
  conMa = "42711K01902,42711k56V01"
  For i = 1 To sRow
    If InStr(1, conMa, sArr(i, 8)) Then slMax = 4 Else slMax = 5
    SL = sArr(i, sCol)
    For r = 1 To SL \ slMax
      k = k + 1
      Res(k, sCol) = slMax
      Call GanDong(sArr, i, Res, k, sCol - 1)
    Next r
    SL = SL Mod slMax
    If SL > 0 Then
      If slMax = 5 Then
        k = k + 1
        Res(k, sCol) = SL
        Call GanDong(sArr, i, Res, k, sCol - 1)
      Else
        For r = 1 To SL
          k = k + 1
          Res(k, sCol) = 1
          Call GanDong(sArr, i, Res, k, sCol - 1)
        Next r
      End If
    End If
  Next i
  With Sheet3
    .Range("A2:Q10000").Clear
    .Range("A2").Resize(k, sCol) = Res
    .Range("A2").Resize(k, sCol).Sort .Range("Q2"), 1, Header:=xlNo
  End With
End Sub

Private Sub GanDong(sArr, i, Res, k, ByVal sC&)
  Dim j&
  For j = 1 To sC
    Res(k, j) = sArr(i, j)
  Next j
End Sub
 
Upvote 0
HieuCD đã viết:
Thử code
Mã: 
Sub ABC()
  Dim sArr(), Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&

  sArr = Sheet2.Range("A2", Sheet2.Range("Q65000").End(xlUp)).Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow * 10, 1 To sCol)
  conMa = "42711K01902,42711k56V01"
  For i = 1 To sRow
    If InStr(1, conMa, sArr(i, 8)) Then slMax = 4 Else slMax = 5
    SL = sArr(i, sCol)
    For r = 1 To SL \ slMax
      k = k + 1
      Res(k, sCol) = slMax
      Call GanDong(sArr, i, Res, k, sCol - 1)
    Next r
    SL = SL Mod slMax
    If SL > 0 Then
      If slMax = 5 Then
        k = k + 1
        Res(k, sCol) = SL
        Call GanDong(sArr, i, Res, k, sCol - 1)
      Else
        For r = 1 To SL
          k = k + 1
          Res(k, sCol) = 1
          Call GanDong(sArr, i, Res, k, sCol - 1)
        Next r
      End If
    End If
  Next i
  With Sheet3
    .Range("A2:Q10000").Clear
    .Range("A2").Resize(k, sCol) = Res
    .Range("A2").Resize(k, sCol).Sort .Range("Q2"), 1, Header:=xlNo
  End With
End Sub

Private Sub GanDong(sArr, i, Res, k, ByVal sC&)
  Dim j&
  For j = 1 To sC
    Res(k, j) = sArr(i, j)
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn ơi xem giúp mình file này với.
Tách rồi nhưng số lượng tách ra không đúng với số lượng gốc(lớn hơn)
=> Trong file mình có note phần kết quả tách mong muốn.
Có gì bạn giúp mình nhé thanks bạn
 

File đính kèm

  • Tach_Drop shipment(F).xlsm
    60 KB · Đọc: 7
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

N
Giúp sửa mã code
2
Trả lời
21
Đọc
480
ptm0412
ptm0412
N
Nhờ các bác hỗ trợ lọc, thống kê dữ liệu giúp
    • Cười
Trả lời
2
Đọc
37
longtay1111
L
T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
12
Đọc
2K
ptm0412
ptm0412
H
Sửa code tính lũy kế ạ
Trả lời
3
Đọc
60
Hoàng Tuấn 868
H
Quyen182
  • Question
Nhờ chỉnh code VBA để tô màu dòng chứa Activecell và không làm mất màu gốc
Trả lời
3
Đọc
109
HeSanbi
HeSanbi
H
Nhờ hướng dẫn tạo bảng như hình vẽ
Trả lời
0
Đọc
44
hoaiantrinh
H
L
Đổi màu chữ trong VBA
Trả lời
11
Đọc
139
lvh1064
L
V
Chỉ cách sửa lỗi trong Excell
Trả lời
1
Đọc
47
A-T
A
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
3
Đọc
148
DeTong
D
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
38
Đọc
2K
lvh1064
L
salam
Ẩn ảnh sau chữ trong excel
Trả lời
11
Đọc
29K
itusbbk
itusbbk
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
4
Đọc
129
nobita994
nobita994
F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
7
Đọc
558
huuthang_bd
huuthang_bd
nguyen trung cuong
File chứa marco không mở được.
Trả lời
3
Đọc
113
hvnhpro
H
Tienvinh191
  • Question
Nhờ viết Code lấy dữ liệu tờ khai hải quan vào bảng tổng hợp
2
Trả lời
25
Đọc
2K
haott
H
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
4
Đọc
96
phansythao
phansythao
dovanha1994
Giúp e tìm nguyên nhân sai và hướng dẫn e đọc file này với ạ
    • Phẫn nộ
Trả lời
4
Đọc
141
SA_DQ
SA_DQ
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
10
Đọc
612
20050911
20050911
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11/2024
    • Thích
    • Yêu thích
Trả lời
1
Đọc
103
SA_DQ
SA_DQ
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
32
Đọc
906
VetMini
V
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

Back
Top Bottom