Xin code tự động tách copy thêm dòng

lqk · 20/5/21

Các anh chị ơi
Em có ca này căng quá nhờ các cao nhân chỉ giáo. Em có 1 file excel đính kèm
Em muốn copy và chèn thêm số dòng tương ứng với số lượng xe yêu cầu và sau khi tách thì số lượng xe yêu cầu sẽ trả về 1.Volume thì chia đều cho mỗi xe
Có nghĩa là cứ 1 xe yêu cầu thì có 1 dòng, 10 xe thì 10 dòng mỗi dòng 1 xe.Volume chia đều cho các xe đó. Nhờ các anh chị cao nhân chỉ giúp em với.
Chứ làm manual ngồi copy , insert , paste thì thực sự mất thời gian quá các anh chị ạ. Nhờ các anh chị hỗ trợ giúp

HieuCD · 21/5/21

lqk đã viết:
Hi các anh chị.
Em có case này căng quá nhờ các cao nhân chỉ giáo. Em có 1 file như trên hình.
Em muốn copy và chèn thêm số dòng tương ứng với số lượng xe yêu cầu và sau khi tách thì số lượng xe yêu cầu sẽ trả về 1.Volume thì chia đều cho mỗi xe
Có nghĩa là cứ 1 xe yêu cầu thì có 1 dòng, 10 xe thì 10 dòng mỗi dòng 1 xe.Volume chia đều cho các xe đó. Nhờ các anh chị cao nhân chỉ giúp em với.
Chứ làm manual ngồi copy , insert , paste thì thực sự mất time quá các anh chị ạ
View attachment 259105

Ca nầy căng quá trời căng, không ai giúp được do:
1/ Vi phạm nội quy diễn đàn, đọc lại nội quy và chỉnh lại bài viết
2/ Code VBA không chạy được trên file ảnh, gởi file excel

SA_DQ · 21/5/21

Kết quả của macro này có ở bên dưới:

PHP:

Sub ThemDongTheo2DieuKien()
 Dim Rws As Long, J As Long, W As Long, SoLgXe As Integer, TKLg As Double, Xe As Byte, Col As Integer
 Dim WF As Object
 
 Rws = [I2].CurrentRegion.Rows.Count
 Set WF = Application.WorksheetFunction
 SoLgXe = WF.Sum([J3].Resize(Rws))
 ReDim Arr(1 To 9 + SoLgXe, 1 To 10)
 [L3].Resize(SoLgXe + 13, 11).ClearContents
 
 For J = 3 To Rws
    TKLg = Cells(J, "H").Value
    SoLgXe = Cells(J, "J").Value
    For Xe = 1 To SoLgXe
        W = W + 1:                   Arr(W, 1) = W
        For Col = 1 To 7
            Arr(W, Col + 1) = Cells(J, Col).Value
        Next Col
        Arr(W, 10) = Cells(J, "I").Value
        Arr(W, 9) = TKLg / SoLgXe
    Next Xe
 Next J
 [L3].Resize(W, 10).Value = Arr()
 
End Sub

Ngày

Mã KH

C03

Địa chỉ

DVT

Kênh

Cti

Khối lượng

C09

Xe YC

$L$1

1

2

3

4

5

6

7

8

9

10

2/13/2021

TLP00

TU

Kg

Hiện đại

GPE.COM

13,794

B13

1

2/13/2021

TLP00

TU

Kg

Hiện đại

GPE.COM

13794

B13

2/25/2021

NVM00

BH

Kg

Hiện đại

GPE.COM

12,247

2

2/25/2021

NVM00

BH

Kg

Hiện đại

GPE.COM

6123.5

3/9/2021

HCQ00

AP

Kg

Hiện đại

GPE.COM

9,226

USA

5

3

2/25/2021

NVM00

BH

Kg

Hiện đại

GPE.COM

6123.5

3/21/2021

TMH00

TDM

Kg

Truyền thống

GPE.COM

24,877

3

4

3/9/2021

HCQ00

AP

Kg

Hiện đại

GPE.COM

1845.2

USA

4/2/2021

BXT00

TĐ

Kg

Truyền thống

GPE.COM

20,243

Tàu

10

5

3/9/2021

HCQ00

AP

Kg

Hiện đại

GPE.COM

1845.2

USA

4/14/2021

LTT00

GV

Kg

Truyền thống

GPE.COM

14,041

1

6

3/9/2021

HCQ00

AP

Kg

Hiện đại

GPE.COM

1845.2

USA

4/26/2021

NVH00

HM

Kg

Hiện đại

GPE.COM

5,739

Ô nhiễm

3

7

3/9/2021

HCQ00

AP

Kg

Hiện đại

GPE.COM

1845.2

USA

SA_DQ · 21/5/21

Nếu đơn vị tính của hàng hóa không phải khối lượng mà là lô, thùng, hộp,. . . (Không xé lẽ cho đều các xe được) thì xài macro này:

PHP:

Sub ThemDongTheo2DieuKien()
 Dim Rws As Long, J As Long, W As Long, SoLgXe As Integer, TKLg As Double
 Dim WF As Object, Xe As Byte, Col As Integer, ConLai As Double
 
 Rws = [I2].CurrentRegion.Rows.Count
 Set WF = Application.WorksheetFunction
 SoLgXe = WF.Sum([J3].Resize(Rws))
 ReDim Arr(1 To 9 + SoLgXe, 1 To 10)
 [L3].Resize(SoLgXe + 9, 11).ClearContents
 
 For J = 3 To Rws
    TKLg = Cells(J, "H").Value
    SoLgXe = Cells(J, "J").Value
    For Xe = 1 To SoLgXe
        W = W + 1:                          Arr(W, 1) = W
        For Col = 1 To 7
            Arr(W, Col + 1) = Cells(J, Col).Value
        Next Col
        Arr(W, 10) = Cells(J, "I").Value
        If Xe < SoLgXe Then
            Arr(W, 9) = TKLg \ SoLgXe
            ConLai = ConLai + Arr(W, 9)
        Else
            Arr(W, 9) = TKLg - ConLai:       ConLai = 0
        End If
    Next Xe
 Next J
 [L3].Resize(W, 10).Value = Arr()
End Sub

lqk · 21/5/21

HieuCD đã viết:
Ca nầy căng quá trời căng, không ai giúp được do:
1/ Vi phạm nội quy diễn đàn, đọc lại nội quy và chỉnh lại bài viết
2/ Code VBA không chạy được trên file ảnh, gởi file excel

dạ em cảm ơn anh

lqk · 21/5/21

SA_DQ đã viết:
Kết quả của macro này có ở bên dưới:

PHP:

Sub ThemDongTheo2DieuKien() Dim Rws As Long, J As Long, W As Long, SoLgXe As Integer, TKLg As Double, Xe As Byte, Col As Integer Dim WF As Object Rws = [I2].CurrentRegion.Rows.Count Set WF = Application.WorksheetFunction SoLgXe = WF.Sum([J3].Resize(Rws)) ReDim Arr(1 To 9 + SoLgXe, 1 To 10) [L3].Resize(SoLgXe + 13, 11).ClearContents For J = 3 To Rws TKLg = Cells(J, "H").Value SoLgXe = Cells(J, "J").Value For Xe = 1 To SoLgXe W = W + 1: Arr(W, 1) = W For Col = 1 To 7 Arr(W, Col + 1) = Cells(J, Col).Value Next Col Arr(W, 10) = Cells(J, "I").Value Arr(W, 9) = TKLg / SoLgXe Next Xe Next J [L3].Resize(W, 10).Value = Arr() End Sub

Ngày Mã KH C03 Địa chỉ DVT Kênh Cti Khối lượng C09 Xe YC $L$1
1 2 3 4 5 6 7 8 9 10
2/13/2021
TLP00 TU Kg Hiện đại GPE.COM
13,794
B13
1
1
2/13/2021
TLP00 TU Kg Hiện đại GPE.COM
13794
B13
2/25/2021
NVM00 BH Kg Hiện đại GPE.COM
12,247
2
2
2/25/2021
NVM00 BH Kg Hiện đại GPE.COM
6123.5
3/9/2021
HCQ00 AP Kg Hiện đại GPE.COM
9,226
USA
5
3
2/25/2021
NVM00 BH Kg Hiện đại GPE.COM
6123.5
3/21/2021
TMH00 TDM Kg Truyền thống GPE.COM
24,877
3
4
3/9/2021
HCQ00 AP Kg Hiện đại GPE.COM
1845.2
USA
4/2/2021
BXT00 TĐ Kg Truyền thống GPE.COM
20,243
Tàu
10
5
3/9/2021
HCQ00 AP Kg Hiện đại GPE.COM
1845.2
USA
4/14/2021
LTT00 GV Kg Truyền thống GPE.COM
14,041
1
6
3/9/2021
HCQ00 AP Kg Hiện đại GPE.COM
1845.2
USA
4/26/2021
NVH00 HM Kg Hiện đại GPE.COM
5,739
Ô nhiễm
3
7
3/9/2021
HCQ00 AP Kg Hiện đại GPE.COM
1845.2
USA

Dạ , cảm ơn anh, nhưng sao em chạy không được anh ơi, em có gửi kèm file, nhờ a xem giúp ạ

Bài đã được tự động gộp: 21/5/21

lqk đã viết:
Dạ , cảm ơn anh, nhưng sao em chạy không được anh ơi, em có gửi kèm file, nhờ a xem giúp ạ

SA_DQ · 21/5/21

Lý ra bạn phải gởi file lên từ đầu; Giờ thì tạm biệt bạn!@

Hoàng Tuấn 868 · 21/5/21

lqk đã viết:
Dạ , cảm ơn anh, nhưng sao em chạy không được anh ơi, em có gửi kèm file, nhờ a xem giúp ạ

E rằng bạn chưa chỉnh lại bài viết cho phù hợp Nội quy thì chưa ai giúp tiếp đâu.

lqk · 21/5/21

Hoàng Tuấn 868 đã viết:
Em rằng bạn chưa chỉnh lại bài viết cho phù hợp Nội quy thì chưa ai giúp tiếp đâu.

mình mới tham gia nên chưa biết nội dung bài viết của mình bị vi phạm nội quy đọc mà vẫng không hiểu. Mong bạn chỉ giúp mình được không ạ.

Bài đã được tự động gộp: 21/5/21

SA_DQ đã viết:
Lý ra bạn phải gởi file lên từ đầu; Giờ thì tạm biệt bạn!@

Cảm ơn anh đã hỗ trợ ạ. Anh có thể giúp em cho em biết em vi phạm nội quy gì không ạ. Để em rút kinh nghiệm.

Phuocam · 21/5/21

Thử:

Mã:

Sub Macro1()
Dim lastRow As Long
Dim i As Long
Dim soXe As Long
Dim tmp As Double
Application.ScreenUpdating = False
With Sheets("Sheet1")
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = lastRow To 2 Step -1
        If .Range("J" & i).Value > 0 Then
            soXe = Application.RoundUp(.Range("I" & i).Value / .Range("j" & i).Value, 0)
        End If
        
        If soXe > 1 Then
            tmp = .Range("I" & i).Value / soXe
            .Range("A" & i).Offset(1).Resize(soXe - 1, 11).Insert
            .Range("A" & i).Offset(1).Resize(soXe - 1, 11).Value = .Range("A" & i).Resize(1, 11).Value
            .Range("I" & i).Resize(soXe).Value = tmp
            .Range("K" & i).Resize(soXe).Value = 1
        Else
            .Range("K" & i) = soXe
        End If
    Next i
End With
Application.ScreenUpdating = False
End Sub

lqk · 21/5/21

phuocam đã viết:

Thử:

Mã:

Sub Macro1()
Dim lastRow As Long
Dim i As Long
Dim soXe As Long
Dim tmp As Double
Application.ScreenUpdating = False
With Sheets("Sheet1")
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = lastRow To 2 Step -1
        If .Range("J" & i).Value > 0 Then
            soXe = Application.RoundUp(.Range("I" & i).Value / .Range("j" & i).Value, 0)
        End If
      
        If soXe > 1 Then
            tmp = .Range("I" & i).Value / soXe
            .Range("A" & i).Offset(1).Resize(soXe - 1, 11).Insert
            .Range("A" & i).Offset(1).Resize(soXe - 1, 11).Value = .Range("A" & i).Resize(1, 11).Value
            .Range("I" & i).Resize(soXe).Value = tmp
            .Range("K" & i).Resize(soXe).Value = 1
        Else
            .Range("K" & i) = soXe
        End If
    Next i
End With
Application.ScreenUpdating = False
End Sub

Dạ cảm ơn anh, thành công rồi ạ

lqk · 21/5/21

phuocam đã viết:

Thử:

Mã:

Sub Macro1()
Dim lastRow As Long
Dim i As Long
Dim soXe As Long
Dim tmp As Double
Application.ScreenUpdating = False
With Sheets("Sheet1")
    lastRow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = lastRow To 2 Step -1
        If .Range("J" & i).Value > 0 Then
            soXe = Application.RoundUp(.Range("I" & i).Value / .Range("j" & i).Value, 0)
        End If
       
        If soXe > 1 Then
            tmp = .Range("I" & i).Value / soXe
            .Range("A" & i).Offset(1).Resize(soXe - 1, 11).Insert
            .Range("A" & i).Offset(1).Resize(soXe - 1, 11).Value = .Range("A" & i).Resize(1, 11).Value
            .Range("I" & i).Resize(soXe).Value = tmp
            .Range("K" & i).Resize(soXe).Value = 1
        Else
            .Range("K" & i) = soXe
        End If
    Next i
End With
Application.ScreenUpdating = False
End Sub

Anh oi, file như em gửi thì đúng, nhưng khi bỏ thêm dữ liệu vào thì khi cộng lại tổng số xe không còn đúng nữa ạ. Ví dụ như ban đầu file em gửi là 83 xe, sau khi tách sẽ ra 83 dòng. Nhưng khi em bỏ dữ liệu mới vào với 85 dòng, 109 xe thì code lại tách thành 119 dòng ( 119 xe ). Em đọc mà ko biết lỗi nằm ở đâu. Anh kiểm tra fix giúp được không ạ

Bài đã được tự động gộp: 21/5/21

lqk đã viết:
Dạ cảm ơn anh, thành công rồi ạ

lqk đã viết:
Anh oi, file như em gửi thì đúng, nhưng khi bỏ thêm dữ liệu vào thì khi cộng lại tổng số xe không còn đúng nữa ạ. Ví dụ như ban đầu file em gửi là 83 xe, sau khi tách sẽ ra 83 dòng. Nhưng khi em bỏ dữ liệu mới vào với 85 dòng, 109 xe thì code lại tách thành 119 dòng ( 119 xe ). Em đọc mà ko biết lỗi nằm ở đâu. Anh kiểm tra fix giúp được không ạ

Phuocam · 21/5/21

lqk đã viết:
Anh oi, file như em gửi thì đúng, nhưng khi bỏ thêm dữ liệu vào thì khi cộng lại tổng số xe không còn đúng nữa ạ. Ví dụ như ban đầu file em gửi là 83 xe, sau khi tách sẽ ra 83 dòng. Nhưng khi em bỏ dữ liệu mới vào với 85 dòng, 109 xe thì code lại tách thành 119 dòng ( 119 xe ). Em đọc mà ko biết lỗi nằm ở đâu. Anh kiểm tra fix giúp được không ạ

File cũ, công thức tính xe:

=IF(A2="","",IF(I2/J2<1,1,ROUNDUP(I2/J2,0)))

File mới, công thức tính xe::

=IF(I2="","",IF(I2<J2,1,ROUND(I2/J2,0))

Só xe của 2 cách tính khác nhau.

SA_DQ · 22/5/21

Nói chung là chủ bài đăng đang thử tài các bạn đó, mại zô!

Xin code tự động tách copy thêm dòng

lqk

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

SA_DQ

/(hông là gì!

SA_DQ

/(hông là gì!

lqk

Thành viên mới

lqk

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

Hoàng Tuấn 868

Đăng ký hôm qua

lqk

Thành viên mới

Phuocam

Thành viên mới

lqk

Thành viên mới

lqk

Thành viên mới

File đính kèm

Phuocam

Thành viên mới

SA_DQ

/(hông là gì!

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

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