Hỗ trợ chuyển một dòng thành bảy dòng

Chia sẻ bởi:hands

★★★★★

‹ Ứng dụng ẩn Module và tạo Project... Cập nhật từ Bảng Phụ sang Bảng... ›

Quảng cáo

Chào anh chị, em có vấn đề này nhờ anh chị hỗ trợ giúp.
Dữ liệu của em là ở Sheet 1. Kết quả mong muốn của em là ở Sheet 2.
Dòng 1: không làm gì hết.
Bắt đầu từ dòng số 2, tức là 1 dòng số 2 ở sheet 1 sẽ trở thành 7 dòng ở sheet 2( dòng 2, 3, 4, 5, 6, 7, 8). Trong 7 dòng thì có sự thay đổi 1 tí. Em có gửi hình, những điểm tô màu đỏ.
Em có viết một đoạn code cũng thực hiện được vấn đề này.
Nhưng đoạn code của em một nữa là mảng, còn một nữa là viết bình thường. Nên khi gặp nhiều dữ liệu là nó chậm.
235
Nhờ anh chị hỗ trợ giúp sửa lại hết thành mảng giúp em. Hoặc viết mới lại hết dùm em cũng được, em cảm ơn anh chị.
Sub MOT_DONG_THANH_BAY_DONG()
Sheet2.Range("A2:CF10000").ClearContents
Dim lr1 As Double, lc1 As Double
lr1 = Sheet1.Range("A1000000").End(xlUp).Row
lc1 = Sheet1.Range("XFD2").End(xlToLeft).Column
Dim lr2 As Double
lr2 = Sheet2.Range("A1000000").End(xlUp).Row
Dim arr1
arr1 = Sheet1.Range(Sheet1.Cells(2, 1), Sheet1.Cells(lr1, lc1)).Value
Dim arr2
ReDim arr2(1 To UBound(arr1, 1) * 7, 1 To UBound(arr1, 2))
For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr1, 2)
For k = 1 To 7
arr2((i - 1) * 7 + k, j) = arr1(i, j)
Next k
Next j
Next i
Sheet2.Range(Sheet2.Cells(lr2 + 1, 1), Sheet2.Cells(lr2 + UBound(arr1, 1) * 7, lc1)).Value = arr2

[B](đoạn dưới lại viết bình thường, không phải là mảng)[/B]
Dim dong_cuoi As Long
dong_cuoi = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
Dim h As Integer
For h = 1 To (dong_cuoi - 1) / 7
Sheet2.Range("E" & (h - 1) * 7 + 3) = "1999"
Sheet2.Range("K" & (h - 1) * 7 + 3) = "701"
Sheet2.Range("I" & (h - 1) * 7 + 4) = "1001"
Sheet2.Range("I" & (h - 1) * 7 + 5) = "1002"
Sheet2.Range("I" & (h - 1) * 7 + 6) = "1003"
Sheet2.Range("I" & (h - 1) * 7 + 7) = "1004"
Sheet2.Range("E" & (h - 1) * 7 + 8) = "4000"
Sheet2.Range("I" & (h - 1) * 7 + 8) = "4000"
Sheet2.Range("G" & (h - 1) * 7 + 8) = "400"
Sheet2.Range("H" & (h - 1) * 7 + 8) = "400"

Next h

Thử code này coi xem thế nào?

Sub ABC()
    Dim sArr(), Res(), i&, j&, K&, iRow&, sR&, sC&
    With Sheets("Sheet1")
        iRow = .Range("A" & Rows.Count).End(3).Row
        sArr = .Range("A2:CF" & iRow).Value
    End With
    sR = UBound(sArr, 1): sC = UBound(sArr, 2)
    ReDim Res(1 To sR * 7, 1 To sC)
    For i = 1 To sR
        For j = 1 To sC
            For K = 1 To 7
                Res((i - 1) * 7 + K, j) = sArr(i, j)
                If K = 2 And j = 5 Then Res((i - 1) * 7 + K, 5) = 1999
                If K = 3 And j = 9 Then Res((i - 1) * 7 + K, 9) = 1001
                If K = 4 And j = 9 Then Res((i - 1) * 7 + K, 9) = 1002
                If K = 5 And j = 9 Then Res((i - 1) * 7 + K, 9) = 1003
                If K = 6 And j = 9 Then Res((i - 1) * 7 + K, 9) = 1004
                If K = 7 And j = 9 Then Res((i - 1) * 7 + K, 9) = 4000
                If K = 7 And j = 5 Then Res((i - 1) * 7 + K, 5) = 4000
                If K = 7 And j = 7 Then Res((i - 1) * 7 + K, 7) = 400
                If K = 7 And j = 8 Then Res((i - 1) * 7 + K, 8) = 400
            Next
        Next
    Next
    Sheets("sheet2").Range("A14").Resize(sR * 7, sC).Value = Res
End Sub

Thử code

Sub ABC()
  Dim arr(), a, d, c, res(), i&, r&, eR&, j&, k&, sR&, sC&

d = Array(2, 2, 3, 4, 5, 6, 7, 7, 7, 7)
  c = Array(5, 11, 9, 9, 9, 9, 5, 7, 8, 9)
  a = Array(1999, 701, 1001, 1002, 1003, 1004, 4000, 400, 400, 4000)
  arr = Sheets("Sheet1").Range("A2:CF" & Sheets("Sheet1").Range("A1048000").End(xlUp).Row).Value
  sR = UBound(arr): sC = UBound(arr, 2)
  ReDim res(1 To sR * 7, 1 To sC)
  For i = 1 To sR
    eR = k
    For r = 1 To 7
      k = k + 1
      For j = 1 To sC
        res(k, j) = arr(i, j)
      Next j
    Next r
    For r = 0 To 9
      res(eR + d(r), c(r)) = a(r)
    Next r
  Next i
  Sheets("sheet2").Range("A2").Resize(k, sC).Value = res
End Sub

www.giaiphapexcel.com/diendan/threads/h%E1%BB%97-tr%E1%BB%A3-chuy%E1%BB%83n-m%E1%BB%99t-d%C3%B2ng-th%C3%A0nh-b%E1%BA%A3y-d%C3%B2ng.161838/#post-1080665