Paste dữ liệu vào bảng gồm các cột có Merge

[ThaiDieuAnh]

Xin chào các anh chị trên GPE. Em có vấn đề này mong các mọi người giúp đỡ ạ:
Trong file đính kèm gồm 1 vùng dữ liệu (Các ô bình thường) có 6 cột (giả định) từ cột A đến cột F. Giờ em muốn copy vùng này để Paste sang 1 vùng có nhiều cột chứa Merge từ cột K đến cột AG.
Điều kiện biết trước là chuỗi: 1;11;3;4;4 (giả định) là số lượng các cột Merge tương ứng từ cột K đến cột AG
Các anh chị giúp em viết thủ tục mà điều kiện biết trước là VungDuLieu, địa chỉ VungKetQua và chuỗi số lượng Merge
Em xin chân thành cảm ơn!

 

[HieuCD]

Xin chào các anh chị trên GPE. Em có vấn đề này mong các mọi người giúp đỡ ạ:
Trong file đính kèm gồm 1 vùng dữ liệu (Các ô bình thường) có 6 cột (giả định) từ cột A đến cột F. Giờ em muốn copy vùng này để Paste sang 1 vùng có nhiều cột chứa Merge từ cột K đến cột AG.
Điều kiện biết trước là chuỗi: 1;11;3;4;4 (giả định) là số lượng các cột Merge tương ứng từ cột K đến cột AG
Các anh chị giúp em viết thủ tục mà điều kiện biết trước là VungDuLieu, địa chỉ VungKetQua và chuỗi số lượng Merge
Em xin chân thành cảm ơn!

Sub ABC()
  Dim sArr(), aCol, Res()
  Dim sRow&, sCol&, sC&, i&, j&, c&
 
  aCol = Array(0, 1, 11, 3, 4, 4)
  For j = 1 To UBound(aCol)
    aCol(j) = aCol(j) + aCol(j - 1)
  Next j
  sC = aCol(j - 1)
  With Sheet1
    sArr = .Range("A4:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sC)
  For i = 1 To sRow
    c = 0
    For j = 1 To sCol
      If j <> 3 Then
        c = c + 1
        Res(i, aCol(c - 1) + 1) = sArr(i, j)
      End If
    Next j
  Next i
  Sheet1.Range("K4").Resize(sRow, sC) = Res
End Sub

 

[ThaiDieuAnh]

Sub ABC()
  Dim sArr(), aCol, Res()
  Dim sRow&, sCol&, sC&, i&, j&, c&

  aCol = Array(0, 1, 11, 3, 4, 4)
  For j = 1 To UBound(aCol)
    aCol(j) = aCol(j) + aCol(j - 1)
  Next j
  sC = aCol(j - 1)
  With Sheet1
    sArr = .Range("A4:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sC)
  For i = 1 To sRow
    c = 0
    For j = 1 To sCol
      If j <> 3 Then
        c = c + 1
        Res(i, aCol(c - 1) + 1) = sArr(i, j)
      End If
    Next j
  Next i
  Sheet1.Range("K4").Resize(sRow, sC) = Res
End Sub

Sub ABC()
  Dim sArr(), aCol, Res()
  Dim sRow&, sCol&, sC&, i&, j&, c&

  aCol = Array(0, 1, 11, 3, 4, 4)
  For j = 1 To UBound(aCol)
    aCol(j) = aCol(j) + aCol(j - 1)
  Next j
  sC = aCol(j - 1)
  With Sheet1
    sArr = .Range("A4:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sC)
  For i = 1 To sRow
    c = 0
    For j = 1 To sCol
      If j <> 3 Then
        c = c + 1
        Res(i, aCol(c - 1) + 1) = sArr(i, j)
      End If
    Next j
  Next i
  Sheet1.Range("K4").Resize(sRow, sC) = Res
End Sub

Cảm ơn anh HieuCD đã giúp đỡ. Code anh chạy ra đúng kết quả, nhưng như ở bài #1 em đã viết là giúp em viết thủ tục (có thể sử dụng được cho nhiều trường hợp) theo kiểu:

Sub ABC (Rng as Range, Rng1 as Range, str as String)

Trong đó:
- Rng là vùng dữ liệu nguồn (Như trong File đính kèm là Range("A3:F32")
- Rng1 là địa chỉ đích (Như trong File đính kèm là Range("K3")
- str là chuỗi (Như trong File đính kèm "0, 1, 11, 3, 4, 4")
Khi có những điều kiện trên thì tại vùng kết quả sẽ tự động Merge theo chuỗi str và đổ dữ liệu tương ứng ở Rng
Em xin cảm ơn

 

[HieuCD]

Cảm ơn anh HieuCD đã giúp đỡ. Code anh chạy ra đúng kết quả, nhưng như ở bài #1 em đã viết là giúp em viết thủ tục (có thể sử dụng được cho nhiều trường hợp) theo kiểu:

Sub ABC (Rng as Range, Rng1 as Range, str as String)

Trong đó:
- Rng là vùng dữ liệu nguồn (Như trong File đính kèm là Range("A3:F32")
- Rng1 là địa chỉ đích (Như trong File đính kèm là Range("K3")
- str là chuỗi (Như trong File đính kèm "0, 1, 11, 3, 4, 4")
Khi có những điều kiện trên thì tại vùng kết quả sẽ tự động Merge theo chuỗi str và đổ dữ liệu tương ứng ở Rng
Em xin cảm ơn

Code không bẩy lổi nhập sai tham số

Sub Main()
  With Sheet1
    Call ABC(.Range("A3:F32"), .Range("K3"), "1,11,3,4,4")
  End With
End Sub
Sub ABC(ByVal sRng As Range, ByVal rRng As Range, ByVal jCol As String)
  Dim sArr(), aCol, Res()
  Dim sRow&, sCol&, sC&, i&, j&, c&
 
  aCol = Split("," & jCol, ",")
  aCol(j) = 0
  For j = 1 To UBound(aCol)
    aCol(j) = CLng(aCol(j)) + aCol(j - 1)
  Next j
  sC = aCol(j - 1)
  sArr = sRng.Value
  sRow = UBound(sArr): sCol = UBound(sArr, 2)
  ReDim Res(1 To sRow, 1 To sC)
 
  For i = 1 To sRow
    c = 0
    For j = 1 To sCol
      If j <> 3 Then
        c = c + 1
        Res(i, aCol(c - 1) + 1) = sArr(i, j)
      End If
    Next j
  Next i
 
  Application.ScreenUpdating = False
  rRng.Resize(sRow, sC) = Res
  Set rRng = rRng.Resize(sRow, sC)
  rRng.UnMerge
  c = 1
  For j = 2 To sC + 1
    If rRng(1, j) <> Empty Or j = sC + 1 Then
      If j > c + 1 Then
        For i = 1 To sRow
          Range(rRng(i, c), rRng(i, j - 1)).Merge
        Next i
      End If
      c = j
    End If
  Next j
  Application.ScreenUpdating = True
End Sub

 

[huuthang_bd]

Nếu là copy - paste thì phải giữ nguyên định dạng và công thức chứ. Ý thớt thế nào?

 

[ThaiDieuAnh]

Nếu là copy - paste thì phải giữ nguyên định dạng và công thức chứ. Ý thớt thế nào?

Code chỉ cần định dạng thôi không cần công thức ạ!
Như bài #1 và #3 thì em muốn đây là thủ tục dùng được nhiều trường hợp. Trong đó:

Sub ABC (Rng as Range, Rng1 as Range, str as String)

- Rng là vùng dữ liệu nguồn (Như trong File đính kèm là Range("A3:F32")
- Rng1 là địa chỉ đích (Như trong File đính kèm là Range("K3" và các ô ở vùng này chưa Merge)
- str là chuỗi (Như trong File đính kèm "0, 1, 11, 3, 4, 4")
Khi thỏa mãn những điều kiện trên thì tại vùng kết quả sẽ tự động Merge các cột theo chuỗi str và đổ dữ liệu tương ứng ở Rng

 

[huuthang_bd]

- Rng là vùng dữ liệu nguồn (Như trong File đính kèm là Range("A3:F32")
- Rng1 là địa chỉ đích (Như trong File đính kèm là Range("K3" và các ô ở vùng này chưa Merge)
- str là chuỗi (Như trong File đính kèm "0, 1, 11, 3, 4, 4")
Khi thỏa mãn những điều kiện trên thì tại vùng kết quả sẽ tự động Merge các cột theo chuỗi str và đổ dữ liệu tương ứng ở Rng

"0,1,11,3,4,4" thì tôi không biết làm, tôi chỉ biết làm kiểu "1,11,0,3,4,4"

Sub Test()
ABC Range("A3:F32"), Range("K3"), "1,11,0,3,4,4"
End Sub
Private Sub ABC(rngSource As Range, rngDest As Range, sStr As String)
On Error GoTo ErrHandler
Dim tmpSh As Worksheet, Arr As Variant, Cll As Range, lRowsCount As Long, i As Long, k As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set tmpSh = Worksheets.Add
lRowsCount = rngSource.Rows.Count
Set Cll = tmpSh.Cells(lRowsCount, rngSource.Columns.Count + 1)
rngSource.Copy
With tmpSh.Cells(1, 1)
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    Cll.Offset(, -1).EntireColumn.Copy Cll.EntireColumn.Cells(1)
End With
Arr = Split(sStr, ",")
For i = UBound(Arr, 1) To 0 Step -1
    k = CLng(Arr(i))
    If k = 0 Then
        tmpSh.Cells(1, i + 1).EntireColumn.Delete Shift:=xlToLeft
    ElseIf k > 1 Then
        tmpSh.Cells(1, i + 2).Resize(, k - 1).EntireColumn.Insert xlToRight
        tmpSh.Cells(1, i + 1).Resize(lRowsCount, k).Merge True
    End If
Next
Range(tmpSh.Cells(1, 1), Cll.Offset(, -1)).Copy rngDest.Cells(1, 1)
ErrHandler:
If Err.Number Then MsgBox Err.Description
tmpSh.Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub