[Giúp] VBA Copy 1 dòng thành nhiều dòng theo điều kiện

[robinhsoon]

Thân chào cả nhà GPEX!.
Mong cả nhà giúp em một việc ạ.
Hiện tại em có 01 File Data (Data bắt đầu từ dòng A26).
Em muốn dòng VBA tìm xem cột R (Remark) nếu bằng T&E thì sẽ chia dòng đó thành 03 dòng.

- Dòng thứ nhất: vẫn giữ nguyên dữ liệu dòng, ở cột N (Đơn giá) tự thêm vào 10.000
- Dòng thứ Hai: vẫn giữ nguyên dữ liệu dòng, ở cột N (Đơn giá) tự thêm vào 30.000
- Dòng thứ Ba: vẫn giữ nguyên dữ liệu dòng, ở cột N (Đơn giá) tự thêm vào 40.000

Mong cả nhà giúp đỡ em.
Em chân thành cảm ơn ạ.

Bài đã được tự động gộp: 24/9/19

 

[snow25]

Thân chào cả nhà GPEX!.
Mong cả nhà giúp em một việc ạ.
Hiện tại em có 01 File Data (Data bắt đầu từ dòng A26).
Em muốn dòng VBA tìm xem cột R (Remark) nếu bằng T&E thì sẽ chia dòng đó thành 03 dòng.

- Dòng thứ nhất: vẫn giữ nguyên dữ liệu dòng, ở cột N (Đơn giá) tự thêm vào 10.000
- Dòng thứ Hai: vẫn giữ nguyên dữ liệu dòng, ở cột N (Đơn giá) tự thêm vào 30.000
- Dòng thứ Ba: vẫn giữ nguyên dữ liệu dòng, ở cột N (Đơn giá) tự thêm vào 40.000

Mong cả nhà giúp đỡ em.
Em chân thành cảm ơn ạ.

Bài đã được tự động gộp: 24/9/19

Nói như bạn lỡ đâu chạy code 2 lần thì nó làm thế nào.

 

[robinhsoon]

Nói như bạn lỡ đâu chạy code 2 lần thì nó làm thế nào.

cảm ơn Anh đã quan tâm ạ,
phần này em chỉ chạy 01 lần ạ, nếu chạy lần 02 thì lập lại như lần 01 thôi ạ, dữ liệu lần 02 sẽ nối tiếp lần 01 thôi ạ.. Trong dữ liêu của em cột B (Full Name) mỗi dòng tương ứng với T&E là một bạn khác nhau.

 

[snow25]

cảm ơn Anh đã quan tâm ạ,
phần này em chỉ chạy 01 lần ạ, nếu chạy lần 02 thì lập lại như lần 01 thôi ạ, dữ liệu lần 02 sẽ nối tiếp lần 01 thôi ạ.. Trong dữ liêu của em cột B (Full Name) mỗi dòng tương ứng với T&E là một bạn khác nhau.

Bạn thử.

Sub dulieu()
    Dim arr, kq, i As Long, j As Long, Lr As Long, R As Long, L As Long, a As Long, k As Long
    With Sheets("DAta")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        If Lr < 27 Then Exit Sub
        arr = .Range("A27:R" & Lr).Value
        R = UBound(arr)
        L = UBound(arr, 2)
        ReDim kq(1 To R * 3, 1 To L)
        For i = 1 To R
        If arr(i, 18) = "T&E" Then
           For k = 1 To 3
               a = a + 1
               For j = 1 To L
                   kq(a, j) = arr(i, j)
               Next j
               If k = 1 Then
                  kq(a, 14) = 10000
               ElseIf k = 2 Then
                  kq(a, 14) = 30000
               Else
                  kq(a, 14) = 40000
               End If
           Next k
      Else
           a = a + 1
           For j = 1 To L
                 kq(a, j) = arr(i, j)
           Next j
      End If
      Next i
      .Range("A27:r27").Resize(a).Value = kq
  End With
End Sub

 

[HieuCD]

Bạn thử.

Sub dulieu()
    Dim arr, kq, i As Long, j As Long, Lr As Long, R As Long, L As Long, a As Long, k As Long
    With Sheets("DAta")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        If Lr < 27 Then Exit Sub
        arr = .Range("A27:R" & Lr).Value
        R = UBound(arr)
        L = UBound(arr, 2)
        ReDim kq(1 To R * 3, 1 To L)
        For i = 1 To R
        If arr(i, 18) = "T&E" Then
           For k = 1 To 3
               a = a + 1
               For j = 1 To L
                   kq(a, j) = arr(i, j)
               Next j
               If k = 1 Then
                  kq(a, 14) = 10000
               ElseIf k = 2 Then
                  kq(a, 14) = 30000
               Else
                  kq(a, 14) = 40000
               End If
           Next k
      Else
           a = a + 1
           For j = 1 To L
                 kq(a, j) = arr(i, j)
           Next j
      End If
      Next i
      .Range("A27:r27").Resize(a).Value = kq
  End With
End Sub

Nên đề phòng chạy code lần 2, kết quả sẻ loạn xà ngầu

 

[snow25]

Nên đề phòng chạy code lần 2, kết quả sẻ loạn xà ngầu

Em đã hỏi bạn đó rồi mà.Ở bài 3 trả lời rồi mà anh..

 

[HieuCD]

Em đã hỏi bạn đó rồi mà.Ở bài 3 trả lời rồi mà anh..

Chủ thớt chưa lường trước việc vô tình bấm nút lệnh chạy lần 2
Khi chạy lần 2 dữ liệu cột B sẽ khác lần 1

Trong dữ liêu của em cột B (Full Name) mỗi dòng tương ứng với T&E là một bạn khác nhau.

 

[robinhsoon]

Bạn thử.

Sub dulieu()
    Dim arr, kq, i As Long, j As Long, Lr As Long, R As Long, L As Long, a As Long, k As Long
    With Sheets("DAta")
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        If Lr < 27 Then Exit Sub
        arr = .Range("A27:R" & Lr).Value
        R = UBound(arr)
        L = UBound(arr, 2)
        ReDim kq(1 To R * 3, 1 To L)
        For i = 1 To R
        If arr(i, 18) = "T&E" Then
           For k = 1 To 3
               a = a + 1
               For j = 1 To L
                   kq(a, j) = arr(i, j)
               Next j
               If k = 1 Then
                  kq(a, 14) = 10000
               ElseIf k = 2 Then
                  kq(a, 14) = 30000
               Else
                  kq(a, 14) = 40000
               End If
           Next k
      Else
           a = a + 1
           For j = 1 To L
                 kq(a, j) = arr(i, j)
           Next j
      End If
      Next i
      .Range("A27:r27").Resize(a).Value = kq
  End With
End Sub

Em cảm ơn Anh ạ, Code hay và đúng ý em lắm.

Chúc anh sức khỏe và thành công ạ

Bài đã được tự động gộp: 24/9/19

Chủ thớt chưa lường trước việc vô tình bấm nút lệnh chạy lần 2
Khi chạy lần 2 dữ liệu cột B sẽ khác lần 1

không sao ạ, em chỉ cần chạy lần 01, lần 02 Thì sẽ process lại từ đầu thôi ạ, cảm ơn Anh đã quan tâm