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

Tình nghĩa giang hồ · 26/8/22

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

(đoạn dưới lại viết bình thường, không phải là mảng)
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

BuiQuangThuan · 26/8/22

Code cũ của bạn nó bị sao à?

VetMini · 26/8/22

Dim a, b
With Sheet2
a = VBA.Array( .[E3], .[K3], .[I4:I8], .[E8], .[G8:H8] )
b = VBA.Array( "1999", "701", [ { "1001"; "1002"; "1003"; "1004"; "4000" } ], "4000", "400" )
aLB = LBound(a)
aUB = UBound(a)
For i = 0 To .Range("A" & Rows.Count).End(xlUp).Row - 7 Step 7
For j = 0 To 4
a(j).Offset(i, 0) = b(j)
Next j
Next i
End With

Tình nghĩa giang hồ · 26/8/22

BuiQuangThuan đã viết:
Code cũ của bạn nó bị sao à?

Code cũ của em chạy bình thường, nhưng mà dữ liệu nhiều sẽ bị chậm, do khúc phía dưới không phải làm mảng.

Bài đã được tự động gộp: 26/8/22

VetMini đã viết:
Dim a, b
With Sheet2
a = VBA.Array( .[E3], .[K3], .[I4:I8], .[E8], .[G8:H8] )
b = VBA.Array( "1999", "701", [ { "1001"; "1002"; "1003"; "1004"; "4000" } ], "4000", "400" )
aLB = LBound(a)
aUB = UBound(a)
For i = 0 To .Range("A" & Rows.Count).End(xlUp).Row - 7 Step 7
For j = 0 To 4
a(j).Offset(i, 0) = b(j)
Next j
Next i
End With

Em cảm ơn anh VietMini nhiều.

BuiQuangThuan · 26/8/22

Tình nghĩa giang hồ đã viết:
Code cũ của em chạy bình thường, nhưng mà dữ liệu nhiều sẽ bị chậm, do khúc phía dưới không phải làm mảng.

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

Mã:

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

Tình nghĩa giang hồ · 26/8/22

BuiQuangThuan đã viết:

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

Mã:

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

Em cảm ơn anh nhiều.

HieuCD · 26/8/22

Thử code

Mã:

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

Tình nghĩa giang hồ · 26/8/22

HieuCD đã viết:

Thử code

Mã:

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

Cũng là mảng mà nhiều cách viết ghê. Chỉ tiếc thầy em chỉ dạy mấy cái cơ bản.
Em cảm ơn anh Hiếu CD.

HieuCD · 26/8/22

Tình nghĩa giang hồ đã viết:
Cũng là mảng mà nhiều cách viết ghê. Chỉ tiếc thầy em chỉ dạy mấy cái cơ bản.
Em cảm ơn anh Hiếu CD.

Có những cách ít người biết hoặc biết nhưng khó ứng dụng vào thực tế, tự mình thử nghiệm khám phá mới tìm được những cách hay

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

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

File đính kèm

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

VetMini

Ăn cùng góc phố

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

HieuCD

Chuyên gia GPE

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

HieuCD

Chuyên gia GPE

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