Chuyển cước vận chuyển xuống dòng dưới bằng VBA

[thinhnx22]

Chào các bạn,
Những dòng nào phát sinh cước vận chuyển, mình muốn cước vận chuyển được chuyển ngay xuống dòng dưới (ngày tháng, mã hàng, tiền hàng được lập lại so với dòng đầu). Dòng nào không phát sinh cước vận chuyển thì được giữ nguyên. Nhờ các bạn giúp theo file đính kèm. Cảm ơn các bạn.

 

[Ba Tê]

Chào các bạn,
Những dòng nào phát sinh cước vận chuyển, mình muốn cước vận chuyển được chuyển ngay xuống dòng dưới (ngày tháng, mã hàng, tiền hàng được lập lại so với dòng đầu). Dòng nào không phát sinh cước vận chuyển thì được giữ nguyên. Nhờ các bạn giúp theo file đính kèm. Cảm ơn các bạn.

Thử code này xem:

Public Sub s_Gpe()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long
sArr = Sheets("NGUON").Range("A5", Sheets("NGUON").Range("A10000").End(xlUp)).Resize(, 4).Value
R = UBound(sArr)
ReDim dArr(1 To R * 2, 1 To 3)
For I = 1 To R
    If sArr(I, 1) <> Empty Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = sArr(I, J)
        Next J
        If sArr(I, 4) > 0 Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 4)
        End If
    End If
Next I
Sheets("KETQUA").Range("E4").Resize(K, 3) = dArr
End Sub

 

[thinhnx22]

Thử code này xem:

Public Sub s_Gpe()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long
sArr = Sheets("NGUON").Range("A5", Sheets("NGUON").Range("A10000").End(xlUp)).Resize(, 4).Value
R = UBound(sArr)
ReDim dArr(1 To R * 2, 1 To 3)
For I = 1 To R
    If sArr(I, 1) <> Empty Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = sArr(I, J)
        Next J
        If sArr(I, 4) > 0 Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 4)
        End If
    End If
Next I
Sheets("KETQUA").Range("E4").Resize(K, 3) = dArr
End Sub

Em test thử đã ok. Cảm ơn bác Ba Tê

 

[Nguyễn Hồng Quang]

Thử code này xem:

Public Sub s_Gpe()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long
sArr = Sheets("NGUON").Range("A5", Sheets("NGUON").Range("A10000").End(xlUp)).Resize(, 4).Value
R = UBound(sArr)
ReDim dArr(1 To R * 2, 1 To 3)
For I = 1 To R
    If sArr(I, 1) <> Empty Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = sArr(I, J)
        Next J
        If sArr(I, 4) > 0 Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 4)
        End If
    End If
Next I
Sheets("KETQUA").Range("E4").Resize(K, 3) = dArr
End Sub

Mong anh Ba tê giúp thêm!vẫn là file này sau khi chạy code của anh; em muốn bổ sung thêm bên sheet "KETQUA" 1 cột ghi chú để phân loại chi phí thì code phải thêm như thế nào ạ
Em gửi kèm file để anh tiện theo dõi

 

[Ba Tê]

Mong anh Ba tê giúp thêm!vẫn là file này sau khi chạy code của anh; em muốn bổ sung thêm bên sheet "KETQUA" 1 cột ghi chú để phân loại chi phí thì code phải thêm như thế nào ạ
Em gửi kèm file để anh tiện theo dõi

Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, TienHang As String, TienVC As String
With Sheets("NGUON")
    sArr = .Range("A5", .Range("A10000").End(xlUp)).Resize(, 4).Value
    TienHang = .Range("C4").Value
    TienVC = .Range("D4").Value
End With
R = UBound(sArr)
ReDim dArr(1 To R * 2, 1 To 4)
For I = 1 To R
    If sArr(I, 1) <> Empty Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = sArr(I, J)
        Next J
        dArr(K, 4) = TienHang
        If sArr(I, 4) > 0 Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 4)
            dArr(K, 4) = TienVC
        End If
    End If
Next I
Sheets("KETQUA").Range("I2").Resize(K, 4) = dArr
End Sub

 

[Nguyễn Hồng Quang]

Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, TienHang As String, TienVC As String
With Sheets("NGUON")
    sArr = .Range("A5", .Range("A10000").End(xlUp)).Resize(, 4).Value
    TienHang = .Range("C4").Value
    TienVC = .Range("D4").Value
End With
R = UBound(sArr)
ReDim dArr(1 To R * 2, 1 To 4)
For I = 1 To R
    If sArr(I, 1) <> Empty Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = sArr(I, J)
        Next J
        dArr(K, 4) = TienHang
        If sArr(I, 4) > 0 Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 4)
            dArr(K, 4) = TienVC
        End If
    End If
Next I
Sheets("KETQUA").Range("I2").Resize(K, 4) = dArr
End Sub

Cảm ơn anh đã giúp đỡ. Chúc anh ngày vui