Xin code VBA biến đổi mảng

[nvh611]

Nhờ anh em trên diễn dàn viets giúp code như file đính kèm
Trân thành cảm ơn các bạn!

 

[HieuCD]

Nhờ anh em trên diễn dàn viets giúp code như file đính kèm
Trân thành cảm ơn các bạn!

Thử code

Sub ABC()
  Dim sArr(), Res()
  Dim sR As Long, sC  As Long, dR  As Long, j As Long, i  As Long, n  As Long, k As Long
  sArr = Range("F2:AJ5").Value
  sR = UBound(sArr): sC = UBound(sArr, 2)
  dR = 6 'So dong ket qua 1 nhom
  ReDim Res(1 To sR * (dR + 1) - 1, 1 To sC)
  For i = 1 To sR
    For n = 1 To dR
      k = (i - 1) * (dR + 1) + n
      For j = 1 To sC
        If Len(sArr(i, j)) > 0 Then
          Res(k, j) = sArr(i, j) + n - 1
        End If
      Next j
    Next n
  Next i
  Range("F8").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub

 

[nvh611]

Thử code

Sub ABC()
  Dim sArr(), Res()
  Dim sR As Long, sC  As Long, dR  As Long, j As Long, i  As Long, n  As Long, k As Long
  sArr = Range("F2:AJ5").Value
  sR = UBound(sArr): sC = UBound(sArr, 2)
  dR = 6 'So dong ket qua 1 nhom
  ReDim Res(1 To sR * (dR + 1) - 1, 1 To sC)
  For i = 1 To sR
    For n = 1 To dR
      k = (i - 1) * (dR + 1) + n
      For j = 1 To sC
        If Len(sArr(i, j)) > 0 Then
          Res(k, j) = sArr(i, j) + n - 1
        End If
      Next j
    Next n
  Next i
  Range("F8").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub

Rất cảm ơn bạn
HieuCD
quá đúng bạn à
Nhưng cho tôi hỏi?
Nếu như các mảng kết quả cách nhau (n- dòng) thì cần thay đổi code ở chỗ nào?
Cảm ơn bạn
HieuCD

 

[HieuCD]

Rất cảm ơn bạn
HieuCD
quá đúng bạn à
Nhưng cho tôi hỏi?
Nếu như các mảng kết quả cách nhau (n- dòng) thì cần thay đổi code ở chỗ nào?
Cảm ơn bạn
HieuCD

Chỉnh tham số mình ghi chú trong code

Sub ABC()
  Dim sArr(), Res()
  Dim sR As Long, sC  As Long, dRow  As Long, dBlank  As Long,j As Long
  sArr = Range("F2:AJ5").Value
  sR = UBound(sArr): sC = UBound(sArr, 2)
  dRow = 6 'So dong ket qua 1 nhom
  dBlank = 3 'So dong trong giua 2 nhom ket qua
  ReDim Res(1 To sR * (dRow + dBlank) - dBlank, 1 To sC)
  For i = 1 To sR
    For n = 1 To dRow
      k = (i - 1) * (dRow + dBlank) + n
      For j = 1 To sC
        If Len(sArr(i, j)) > 0 Then
          Res(k, j) = sArr(i, j) + n - 1
        End If
      Next j
    Next n
  Next i
  Range("F8").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub

 

[nvh611]

Chỉnh tham số mình ghi chú trong code

Sub ABC()
  Dim sArr(), Res()
  Dim sR As Long, sC  As Long, dRow  As Long, dBlank  As Long,j As Long
  sArr = Range("F2:AJ5").Value
  sR = UBound(sArr): sC = UBound(sArr, 2)
  dRow = 6 'So dong ket qua 1 nhom
  dBlank = 3 'So dong trong giua 2 nhom ket qua
  ReDim Res(1 To sR * (dRow + dBlank) - dBlank, 1 To sC)
  For i = 1 To sR
    For n = 1 To dRow
      k = (i - 1) * (dRow + dBlank) + n
      For j = 1 To sC
        If Len(sArr(i, j)) > 0 Then
          Res(k, j) = sArr(i, j) + n - 1
        End If
      Next j
    Next n
  Next i
  Range("F8").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub

Trời!
Bạn
HieuCD
Cảm ơn bạn rất nhiều.
Chúc bạn luôn luôn gặp nhiều hạnh phúc.