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) (1 người xem)

  • Thread starter Thread starter khkkh
  • Ngày gửi Ngày gửi
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)
K

khkkh

Thành viên mới
Tham gia
29/5/12
Bài viết
40
Đượ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

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

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

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

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

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

Upvote 0
SEAHAI đã viết:
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é Cảm ơn bạn
Nhấp chuột vào đây để mở rộng...
Kq(x, cls) = Gh
Chỉnh lại
Kq(x, cls) = k
Mã: 
    If k Then
        If Gh = 5 Then
            x = x + 1
            Kq(x, cls) = k
            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
 
Upvote 0
HieuCD đã viết:
Kq(x, cls) = Gh
Chỉnh lại
Kq(x, cls) = k
Mã: 
    If k Then
        If Gh = 5 Then
            x = x + 1
            Kq(x, cls) = k
            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
Nhấp chuột vào đây để mở rộng...
OK phần số lượng tách với số lượng gốc
Vẫn còn vấn đề là tách không đúng như mình mong muốn
Mình muốn kết quả tách như sau.
Note: Mã hàng 42711K01902 & 42711k56V01
Tách theo số lượng 4
Ví Dụ :
* số lượng > 4
-42711K01902 có số lượng 10 thì tách ra làm 4 dòng (2 dòng số lượng 4 và 2 dòng số lượng 1)
* số lượng = 4 không tách

* số lượng < 4 Tách thành 1

42711K01902 có số lượng 3 thì tách ra làm 3 dòng số lượng 1

=> Còn lại những mã hàng khác tách theo số lượng 5

Ví dụ :

* số lượng >5

Mã hàng 42711GBGB20 có số lượng 8 thì tách làm 2 dòng( 1 dòng số lượng 5 và 1 dòng số lượng 3)

* số lượng <=5 không tách
Bạn giúp mình với nhé.
Thanks
 
Upvote 0
SEAHAI đã viết:
OK phần số lượng tách với số lượng gốc
Vẫn còn vấn đề là tách không đúng như mình mong muốn
Mình muốn kết quả tách như sau.
Note: Mã hàng 42711K01902 & 42711k56V01
Tách theo số lượng 4
Ví Dụ :
* số lượng > 4
-42711K01902 có số lượng 10 thì tách ra làm 4 dòng (2 dòng số lượng 4 và 2 dòng số lượng 1)
* số lượng = 4 không tách

* số lượng < 4 Tách thành 1

42711K01902 có số lượng 3 thì tách ra làm 3 dòng số lượng 1

=> Còn lại những mã hàng khác tách theo số lượng 5

Ví dụ :

* số lượng >5

Mã hàng 42711GBGB20 có số lượng 8 thì tách làm 2 dòng( 1 dòng số lượng 5 và 1 dòng số lượng 3)

* số lượng <=5 không tách
Bạn giúp mình với nhé.
Cảm ơn
Nhấp chuột vào đây để mở rộng...
Chạy code của mình gởi chưa
 
Upvote 0
HieuCD đã viết:
Chạy code của mình gởi chưa
Nhấp chuột vào đây để mở rộng...
Code này phải không bạn.
Nếu code này thì như ý trên mình nói.
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 = Sheet1.Range("A2", Sheet1.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) = k
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 Sheet2
.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
SEAHAI đã viết:
Code này phải không bạn.
Nếu code này thì như ý trên mình nói.
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 = Sheet1.Range("A2", Sheet1.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) = k
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 Sheet2
.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...
Sub ABC() bài #19 mờ
 
Upvote 0
SEAHAI đã viết:
Code đó nhấn tách không chạy được bạn ơi.
Nhấp chuột vào đây để mở rộng...
Code đó viết cho file bài #7
Chỉnh lại tên sheet cho file mới
Mã: 
Sub ABC()
  Dim sArr(), Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&
 
  With Sheets("DL_IRV")
    sArr = .Range("A2", .Range("Q65000").End(xlUp)).Value
  End With
  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 Sheets("KQ_IRV")
    .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
 

File đính kèm

Upvote 0
HieuCD đã viết:
Code đó viết cho file bài #7
Chỉnh lại tên sheet cho file mới
Mã: 
Sub ABC()
  Dim sArr(), Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&

  With Sheets("DL_IRV")
    sArr = .Range("A2", .Range("Q65000").End(xlUp)).Value
  End With
  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 Sheets("KQ_IRV")
    .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...
Chuẩn luôn rồi bạn ơi ,cảm ơn bạn nhiều nhé.
 
Upvote 0
HieuCD đã viết:
Code đó viết cho file bài #7
Chỉnh lại tên sheet cho file mới
Mã: 
Sub ABC()
  Dim sArr(), Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&

  With Sheets("DL_IRV")
    sArr = .Range("A2", .Range("Q65000").End(xlUp)).Value
  End With
  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 Sheets("KQ_IRV")
    .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 lại nhờ bạn chút cho hoàn chỉnh file .
+Sau khi làm xong mình lưu lại thì báo lỗi như file đính kèm(bạn xem lỗi này như thế nào giúp mình với)
+ sau khi sắp sếp theo số lượng từ nhỏ đến lớn thì qua sắp xếp mã hàng từ nhỏ đến lớn.
Thanks
 

File đính kèm

Upvote 0
SEAHAI đã viết:
Bạn ơi lại nhờ bạn chút cho hoàn chỉnh file .
+Sau khi làm xong mình lưu lại thì báo lỗi như file đính kèm(bạn xem lỗi này như thế nào giúp mình với)
+ sau khi sắp sếp theo số lượng từ nhỏ đến lớn thì qua sắp xếp mã hàng từ nhỏ đến lớn.
Cảm ơn
Nhấp chuột vào đây để mở rộng...
Lỗi từ file gốc, có thể do cài add in tự tạo, do phần mềm xuất ra excel không chuẩn ..., bạn tạo file mới và copy dán giá trị vào file mới sẽ hết lỗi
Chỉnh lệnh Sort
.Range("A2").Resize(k, sCol).Sort .Range("Q2"), 1, Range("H2"), , 1, Header:=xlNo
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Lỗi từ file gốc, có thể do cài add in tự tạo, do phần mềm xuất ra excel không chuẩn ..., bạn tạo file mới và copy dán giá trị vào file mới sẽ hết lỗi
Chỉnh lệnh Sort
.Range("A2").Resize(k, sCol).Sort .Range("Q2"), 1, Range("H2"), , 1, Header:=xlNo
Nhấp chuột vào đây để mở rộng...
Thanks bạn
 
Upvote 0
HieuCD đã viết:
Code đó viết cho file bài #7
Chỉnh lại tên sheet cho file mới
Mã: 
Sub ABC()
  Dim sArr(), Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&

  With Sheets("DL_IRV")
    sArr = .Range("A2", .Range("Q65000").End(xlUp)).Value
  End With
  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 Sheets("KQ_IRV")
    .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 lại nhờ bạn xíu.
Vẫn là file hôm bữa (vẫn tách như cũ)
Nhưng giờ mình muốn SHEET KQ thể hiện những cột cần(những cột không cần thì không lấy qua) + Thêm cột "No." tự đông đánh số thứ tự khi các bước tách và sort xong(
Note : Tách =>Sort số lượng từ nhỏ đến lớn => Sort mã hàng từ nhỏ đến lớn => tự động đánh số thứ tự từ nhỏ đến lớn.
Mình đính kèm file phía dưới nhé.
Bạn xem làm giúp mình nhé.
Cảm ơn bạn nhiều.
 

File đính kèm

Upvote 0
SEAHAI đã viết:
Bạn ơi lại nhờ bạn xíu.
Vẫn là file hôm bữa (vẫn tách như cũ)
Nhưng giờ mình muốn SHEET KQ thể hiện những cột cần(những cột không cần thì không lấy qua) + Thêm cột "No." tự đông đánh số thứ tự khi các bước tách và sort xong(
Note : Tách =>Sort số lượng từ nhỏ đến lớn => Sort mã hàng từ nhỏ đến lớn => tự động đánh số thứ tự từ nhỏ đến lớn.
Mình đính kèm file phía dưới nhé.
Bạn xem làm giúp mình nhé.
Cảm ơn bạn nhiều.
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub ABC()
  Dim sArr(), acol, Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&
 
  acol = Array("", 1, 2, 8, 9, 11)
  conMa = "42711K01902,42711k56V01"
  With Sheets("DL_IRV")
    sArr = .Range("A2", .Range("Q65000").End(xlUp)).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow * 10, 1 To 7)
 
  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, 6) = slMax
      Call GanDong(sArr, i, Res, k, acol)
    Next r
    SL = SL Mod slMax
    If SL > 0 Then
      If slMax = 5 Then
        k = k + 1
        Res(k, 6) = SL
        Call GanDong(sArr, i, Res, k, acol)
      Else
        For r = 1 To SL
          k = k + 1
          Res(k, 6) = 1
          Call GanDong(sArr, i, Res, k, acol)
        Next r
      End If
    End If
  Next i
  With Sheets("KQ_IRV")
    .Range("A2:G10000").Clear
    .Range("B2").Resize(k, 7) = Res
    .Range("B2").Resize(k, 7).Sort .Range("G2"), 1, Range("D2"), , 1, Header:=xlNo
    .Range("A2") = 1
    .Range("A2").Resize(k).DataSeries
  End With
End Sub

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

  acol = Array("", 1, 2, 8, 9, 11)
  conMa = "42711K01902,42711k56V01"
  With Sheets("DL_IRV")
    sArr = .Range("A2", .Range("Q65000").End(xlUp)).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow * 10, 1 To 7)

  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, 6) = slMax
      Call GanDong(sArr, i, Res, k, acol)
    Next r
    SL = SL Mod slMax
    If SL > 0 Then
      If slMax = 5 Then
        k = k + 1
        Res(k, 6) = SL
        Call GanDong(sArr, i, Res, k, acol)
      Else
        For r = 1 To SL
          k = k + 1
          Res(k, 6) = 1
          Call GanDong(sArr, i, Res, k, acol)
        Next r
      End If
    End If
  Next i
  With Sheets("KQ_IRV")
    .Range("A2:G10000").Clear
    .Range("B2").Resize(k, 7) = Res
    .Range("B2").Resize(k, 7).Sort .Range("G2"), 1, Range("D2"), , 1, Header:=xlNo
    .Range("A2") = 1
    .Range("A2").Resize(k).DataSeries
  End With
End Sub

Private Sub GanDong(sArr, i, Res, k, acol)
  Dim j&
  For j = 1 To UBound(acol)
    Res(k, j) = sArr(i, acol(j))
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều nhé
 
Upvote 0
HieuCD đã viết:
Mã: 
Sub ABC()
  Dim sArr(), acol, Res(), conMa$, SL&, slMax&
  Dim i&, r&, k&, sRow&, sCol&

  acol = Array("", 1, 2, 8, 9, 11)
  conMa = "42711K01902,42711k56V01"
  With Sheets("DL_IRV")
    sArr = .Range("A2", .Range("Q65000").End(xlUp)).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow * 10, 1 To 7)

  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, 6) = slMax
      Call GanDong(sArr, i, Res, k, acol)
    Next r
    SL = SL Mod slMax
    If SL > 0 Then
      If slMax = 5 Then
        k = k + 1
        Res(k, 6) = SL
        Call GanDong(sArr, i, Res, k, acol)
      Else
        For r = 1 To SL
          k = k + 1
          Res(k, 6) = 1
          Call GanDong(sArr, i, Res, k, acol)
        Next r
      End If
    End If
  Next i
  With Sheets("KQ_IRV")
    .Range("A2:G10000").Clear
    .Range("B2").Resize(k, 7) = Res
    .Range("B2").Resize(k, 7).Sort .Range("G2"), 1, Range("D2"), , 1, Header:=xlNo
    .Range("A2") = 1
    .Range("A2").Resize(k).DataSeries
  End With
End Sub

Private Sub GanDong(sArr, i, Res, k, acol)
  Dim j&
  For j = 1 To UBound(acol)
    Res(k, j) = sArr(i, acol(j))
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn ơi xem lại mình giúp mã hàng vẫn chưa sort được từ nhỏ đến lớn .(cùng mã hàng mà lại làm nhiều dòng khác nhau => Chưa nằm gần nhau)
 
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

N
Nhờ giúp Drop down list theo tỉnh xã mới. (1 người xem)
Trả lời
0
Đọc
27
nnt32002
N
ongke0711
Truy cập trang GPE chậm (4 người xem)
    • Thích
Trả lời
3
Đọc
112
Hai Lúa Miền Tây
Hai Lúa Miền Tây
N
Định mức nguyên vật liệu
Trả lời
48
Đọc
5K
ptm0412
ptm0412
V
Quản lý xuất nhập vật tư trong kho
Trả lời
9
Đọc
357
Vũ Hải Sơn
V
V
Gộp File Từng File Excel vào 1 File
Trả lời
16
Đọc
374
ptm0412
ptm0412
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb
Trả lời
10
Đọc
698
Zizi One
Zizi One
I
Phân bổ số lượng xuất kho trong kỳ theo từng mã nguyên vật liệu
Trả lời
6
Đọc
154
IrisQ
I
L
Các bạn giúp mình hoàn thiện công thức hàm sumif nhé
Trả lời
5
Đọc
117
lequang_qn
L
N
Xin file tính khẩu phần ăn cho trường mầm non
Trả lời
5
Đọc
6K
HUONGHCKT
H
Gà Công Nghệ
Cập nhật dữ liệu từ sheet này sang sheet khác
Trả lời
14
Đọc
242
HUONGHCKT
H
queluatb
Tự động tăng số hóa đơn theo điều kiện
Trả lời
4
Đọc
155
queluatb
queluatb
HeSanbi
  • Đã giải quyết
VBA_FastCode v2.22 - Công cụ học và viết mã VBA một cách nhanh nhất (*27/10/2023) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
53
Đọc
18K
sutu
S
hung2412
Nhờ giúp Lấy sao kê giao dịch từ Trang Web BIDV bằng VBA
Trả lời
6
Đọc
247
ongke0711
ongke0711
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
15
Đọc
1K
Tuanba1992
Tuanba1992
T
Kính nhờ Anh chị hỗ trợ giúp e công thức giúp e với ạ! (1 người xem)
Trả lời
3
Đọc
79
IrisQ
I
L
Hàm nối ký tự trong 1 cell khi trong cell các ký tự xuống dòng
Trả lời
2
Đọc
116
HieuCD
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
    • Thích
Trả lời
25
Đọc
1K
HUONGHCKT
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
425
Đọc
56K
Hoàng Tuấn 868
H
J
Xử lý các file Excel bị nặng sau nhiều năm sử dụng
Trả lời
19
Đọc
2K
Hà Tiềm
H
Nguyễn Duy Tuân
PHƯƠNG PHÁP TRÍCH XUẤT NGƯỢC BÁO CÁO - Drilldown và Add-in A-Tools
    • Thích
Trả lời
1
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
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