Viết code tạo tranpose data

[nghiaquangtran]

Chào các bạn

Mình có 1 dạng số liệu và hàng tháng phải làm công việc tranpose lại chúng theo định dang mới, các bạn giúp mình đoạn code có thể định dạng theo yêu cầu nhé, mình có pót file mẫu lên để các bạn xem dùm.

Cám ơn nhiều

 

[chibi]

Đơn giản thì sử dụng đoạn code này

Sub transpose_chibi()
Dim iR As Integer, iC As Integer, cR As Integer
    cR = 10
    For iR = 2 To 4
        For iC = 2 To 10
            Cells(cR, 1) = Cells(iR, 1)
            Cells(cR, 2) = Cells(1, iC)
            Cells(cR, 3) = Cells(iR, iC)
            cR = cR + 1
        Next
    Next
End Sub

 

[ChanhTQ@]

Bạn hãy chạy thử với cặp macro sau

Option Explicit
Sub CopyValue()
 Dim eR As Long, Jj As Long
 Dim Rng As Range, cRng As Range
 
 eR = Range("B1").CurrentRegion.Rows.Count
 Set Rng = Range([b1], [b1].End(xlToRight))
 Range("B10:C" & eR * [A65500].End(xlUp).Row).ClearContents
 For Jj = 2 To eR
   Rng.Copy
   Set cRng = [B65500].End(xlUp).Offset(1)
   TransCopy cRng:                        Rng.Offset(Jj - 1).Copy
   TransCopy cRng.Offset(, 1)
 Next Jj
 Application.CutCopyMode = False
End Sub

Sub TransCopy(Rng As Range)
 Rng.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=True
End Sub

 

[ndu96081631]

Thử code này xem thế nào nhé:

Sub Transpose()
  Dim Src As Range, i As Long
  With Application.InputBox("Chon vung can copy", Type:=8)
    With Intersect(.Cells, .Offset(1, 1))
      Set Src = Application.InputBox("Chon 1 cell noi ban can dat ket qua", Type:=8)
      For i = 0 To .Rows.Count - 1
        Src(1, 1).Resize(.Columns.Count, 1) = .Cells(i + 1, 0)
        Union(.Offset(-1).Resize(1), .Offset(i).Resize(1)).Copy
        Src(1, 2).PasteSpecial 3, , , True
        Set Src = Src.Offset(.Columns.Count)(1, 1)
      Next i
    End With
  End With
  Application.CutCopyMode = False
End Sub

Sub này có khả năng copy paste chẳng những nội trong sheet mà còn cho phép copy từ sheet này sang sheet khác.. thậm chí sang 1 file khác luôn

 

[nghiaquangtran]

Thử code này xem thế nào nhé:

Sub Transpose()
  Dim Src As Range, i As Long
  With Application.InputBox("Chon vung can copy", Type:=8)
    With Intersect(.Cells, .Offset(1, 1))
      Set Src = Application.InputBox("Chon 1 cell noi ban can dat ket qua", Type:=8)
      For i = 0 To .Rows.Count - 1
        Src(1, 1).Resize(.Columns.Count, 1) = .Cells(i + 1, 0)
        Union(.Offset(-1).Resize(1), .Offset(i).Resize(1)).Copy
        Src(1, 2).PasteSpecial 3, , , True
        Set Src = Src.Offset(.Columns.Count)(1, 1)
      Next i
    End With
  End With
  Application.CutCopyMode = False
End Sub

Sub này có khả năng copy paste chẳng những nội trong sheet mà còn cho phép copy từ sheet này sang sheet khác.. thậm chí sang 1 file khác luôn

Cám ơn các bạn đã gúp đỡ.

To Ndu: Cám ơn bạn Ndu nhé...code viết quá siêu

 

[nghiaquangtran]

Cám ơn các bạn đã gúp đỡ.

To Ndu: Cám ơn bạn Ndu nhé...code viết quá siêu

To Ndu.

Mình có chút nhờ bạn giúp thêm, vì bảng data gốc của mình hiện được thêm 1 hàng nữa nên số hàng cần transpose là 4 hàng thành 4 cột, bạn giúp mình sửa lại code theo đoạn code bạn viết dùm mình trước nhé...trình độ mình chưa đủ tầm để sửa dc nó...hix


Cám ơn Ndu nhiều
Thân

 

[ndu96081631]

To Ndu.

Mình có chút nhờ bạn giúp thêm, vì bảng data gốc của mình hiện được thêm 1 hàng nữa nên số hàng cần transpose là 4 hàng thành 4 cột, bạn giúp mình sửa lại code theo đoạn code bạn viết dùm mình trước nhé...trình độ mình chưa đủ tầm để sửa dc nó...hix


Cám ơn Ndu nhiều
Thân

Sửa lại có vài chổ là được
Thay:
With Intersect(.Cells, .Offset(1, 1))
Thành:
With Intersect(.Cells, .Offset(2, 1))
Thay:
Union(.Offset(-1).Resize(1), .Offset(i).Resize(1)).Copy
Thành:
Union(.Offset(-2).Resize(2), .Offset(i).Resize(1)).Copy
Còn lại giữ nguyên

Sub Transpose()
  Dim Src As Range, i As Long
  With Application.InputBox("Chon vung can copy", Type:=8)
    With Intersect(.Cells, .Offset(2, 1))
      Set Src = Application.InputBox("Chon 1 cell noi ban can dat ket qua", Type:=8)
      For i = 0 To .Rows.Count - 1
        Src(1, 1).Resize(.Columns.Count, 1) = .Cells(i + 1, 0)
        Union(.Offset(-2).Resize(2), .Offset(i).Resize(1)).Copy
        Src(1, 2).PasteSpecial 3, , , True
        Set Src = Src.Offset(.Columns.Count)(1, 1)
      Next i
    End With
  End With
  Application.CutCopyMode = False
End Sub