Chuyển dữ liệu từ cột thành dòng (6 người xem)

[luungocthuc]

Nhờ mọi người vấn đề như sau:

Mình có dữ liệu dạng như bảng đính kèm nhưng nhiều cột và hàng hơn (cỡ vài trăm cột và vài trăm dòng). Bgio mình muốn chuyển dữ liệu từ cột thành dòng để tiện khi in báo cáo.

Cũng có nhiều người hỏi vấn đề này rồi nhưng do đang cần ngay nên mạo muội lập theard để hỏi cho nhanh.
Rất mong sự giúp đỡ của mọi người.

Trân trọng cám ơn.

Đã tìm kiếm trên mạng từ sáng đến giờ mà vẫn chưa có cách thực hiện. Rất mong mọi người giúp đỡ, cái này rất cần để mình thực hiện báo cáo.

Trân trọng cám ơn.

 

[thehungqnu]

Chuyển dữ liệu

Bạn dùng code này xem thử đúng yêu cầu chưa.

Sub Dong_cot()
Dim i As Integer
Dim j As Integer
Dim endR As Long
Dim endC As Long
Dim a As Integer
Dim b As Integer
a = 5
Application.ScreenUpdating = False
On Error Resume Next
With Sheets("sheet2")
    .Range("A5:G65000").ClearContents
    .Cells(4, 1).Value = Cells(4, 1).Value
    .Cells(4, 2).Value = Cells(4, 2).Value
    .Cells(4, 3).Value = Cells(4, 4).Value
    .Cells(4, 4).Value = Cells(4, 5).Value
    .Cells(4, 5).Value = Cells(4, 6).Value
End With
endR = Range("B65000").End(xlUp).Row
endC = (Range("A4").End(xlToRight).Column) - 2
For i = 5 To endR
    With Sheets("sheet2")
        .Cells(a, 1).Value = Cells(i, 1).Value
        .Cells(a, 2).Value = Cells(i, 2).Value
    End With
    b = 1
    For j = 1 To endC Step 4
            With Sheets("sheet2")
                .Cells(a + b, 2).Value = Cells(i, j + 2).Value
                .Cells(a + b, 3).Value = Cells(i, j + 3).Value
                .Cells(a + b, 4).Value = Cells(i, j + 4).Value
                .Cells(a + b, 5).Value = Cells(i, j + 5).Value
            End With
            b = b + 1
    Next j
    a = a + 4
Next i
Sheets("sheet2").Activate
    MsgBox ("Qua da!!!!!!!!!!!")
End Sub

-----------hoặc file dưới--------

 

[thehungqnu]

Chuyển dữ liệu

code cũ chỉ thêm được DL dòng nhưng không thêm được cột.
mình làm code này có thể thêm dữ liệu ở dòng và cột không hạn chế

Sub Dong_cot()
Dim i As Integer
Dim j As Integer
Dim endR As Long
Dim endC As Long
Dim a As Integer
Dim b As Integer
a = 5
Application.ScreenUpdating = False
On Error Resume Next
With Sheets("sheet2")
    .Range("A5:G65000").ClearContents
    .Cells(4, 1).Value = Cells(4, 1).Value
    .Cells(4, 2).Value = Cells(4, 2).Value
    .Cells(4, 3).Value = Cells(4, 4).Value
    .Cells(4, 4).Value = Cells(4, 5).Value
    .Cells(4, 5).Value = Cells(4, 6).Value
End With
endR = Range("B65000").End(xlUp).Row
endC = (Range("A4").End(xlToRight).Column) - 2
For i = 5 To endR
    With Sheets("sheet2")
        .Cells(a, 1).Value = Cells(i, 1).Value
        .Cells(a, 2).Value = Cells(i, 2).Value
    End With
    b = 1
    For j = 1 To endC Step 4
            With Sheets("sheet2")
                .Cells(a + b, 2).Value = Cells(i, j + 2).Value
                .Cells(a + b, 3).Value = Cells(i, j + 3).Value
                .Cells(a + b, 4).Value = Cells(i, j + 4).Value
                .Cells(a + b, 5).Value = Cells(i, j + 5).Value
            End With
            b = b + 1
    Next j
    a = a + b'sua cho nay
Next i
Application.ScreenUpdating = True
    Sheets("sheet2").Activate
    MsgBox ("Qua da!!!!!!!!!!!")
End Sub

hoặc file đã sửa.

 

[ptm0412]

Code dự phòng cho nhiều dòng và nhiều cột. Dự phòng cho cả ô trống: 1 SP nào đó chỉ có 1 vài nhà sản xuất. Code của thehungqnu sẽ cho những dòng trống.

Nhanh hơn. Nếu dùng mảng sẽ nhanh hơn nữa, nhưng chưa làm kịp.

Sub chuyen()
Application.ScreenUpdating = False
t = Timer
endR = [A65000].End(xlUp).Row
endC = [IV4].End(xlToLeft).Column
iR2 = 2
With Sheet2
.Range("H2:L10000").ClearContents
For iR = 5 To endR
    .Cells(iR2, 8).Resize(1, 2) = Cells(iR, 1).Resize(1, 2).Value
    iR2 = iR2 + 1
    For jc = 3 To endC Step 4
       If Len(Cells(iR, jc)) = 0 Then
            GoTo Next1
        Else
            .Cells(iR2, 9) = Cells(4, jc).Value
            .Cells(iR2, 10).Resize(1, 3) = Cells(iR, jc).Offset(0, 1).Resize(1, 3).Value
            iR2 = iR2 + 1
        End If
Next1:
    Next
Next
.[g1] = Timer - t
End With
Application.ScreenUpdating = True
End Sub

 

[ptm0412]

Code dùng mảng. Với 5000 dòng, 22 cột dữ liệu gốc, 30000 dòng kết quả, dùng mảng nhanh gấp 4.5 lần code bài trên (0.78 giây)

Sub chuyen2()
Dim ArrKQ, ArrGoc
t = Timer
Application.ScreenUpdating = False
endR = [A65000].End(xlUp).Row
endC = [IV4].End(xlToLeft).Column
ReDim ArrKQ(1 To (endR - 4) * (endC / 4 + 1), 1 To 5)
ir2 = 1
ArrGoc = Range(Cells(5, 1), Cells(endR, endC))
With Sheet2
.Range("a2:e50000").ClearContents
For ir = 1 To endR - 4
    ArrKQ(ir2, 1) = ArrGoc(ir, 1)
    ArrKQ(ir2, 2) = ArrGoc(ir, 2)
        ir2 = ir2 + 1
    For jc = 3 To endC Step 4
       If Len(ArrGoc(ir, jc)) = 0 Then
            GoTo Next1
        Else
            ArrKQ(ir2, 2) = Cells(4, jc)
            ArrKQ(ir2, 3) = ArrGoc(ir, jc + 1)
            ArrKQ(ir2, 4) = ArrGoc(ir, jc + 2)
            ArrKQ(ir2, 5) = ArrGoc(ir, jc + 3)
            ir2 = ir2 + 1
        End If
Next1:
    Next
Next
Sheet2.Range("A2:E" & UBound(ArrKQ)) = ArrKQ
End With
Application.ScreenUpdating = True
    Sheet2.Activate
    Sheet2.[g2] = Timer - t
End Sub

 

[trankhanhlvc]

Mình muốn chuyển đổi cột thành dòng như trong file đính kèm để in trên trang giấy ngang thì phải làm thế nào, do phần mềm công ty mình xuất ra dữ liệu chỉ có một cột, mình muốn chuyển cột ấy thành các dòng để in vừa trên trang giấy! Mọi người giúp mình với. Thanks all!!!

 

[sealand]

Mình tham gia cách dùng công thức, bạn xem trong file

 

[sealand]

Hi, Code mảng của Ptm 0412 khá ngon rồi, nhưng vì ấn tượng về tốc độ nên mình cũng thử viết lại bằng mảng xem sao? Để có thể vượt qua giới hạn của anh Ptm 0412 mình phải loay hoay mất đúng buổi tối qua. Cuối cùng mình cũng vượt qua giới hạn của Ptm0412 là 0,67s còn 0,48s. Code của mình thế này (Đúng là dùng mảng so với dùng Cell thì kết quả như mơ)

Sub chuyen3()
Dim Mg1, Mg2(), Cty
Dim i, j, n, m, m1
Application.ScreenUpdating = False
t = Timer
 Mg1 = Range([A5], [A5].SpecialCells(xlLastCell))
  Cty = [A4].Resize(, UBound(Mg1, 2))
   j = 1
    n = 2
     ReDim Mg2(1 To 65000, 1 To 5)
      For i = 1 To UBound(Mg1, 1)
       Mg2(j, 1) = Mg1(i, 1)
        Mg2(j, 2) = Mg1(i, 2)
         j = j + 1
          For m = 3 To UBound(Mg1, 2) Step 4
           If Mg1(i, m) <> "" Then
             For m1 = 0 To 3
              If n = 2 Then
             Mg2(j, 2) = Cty(1, m)
            Else
           Mg2(j, n) = Mg1(i, m + m1)
          End If
         n = n + 1
        If n = 6 Then
       n = 2
      j = j + 1
    End If
   Next m1
  End If
 Next m
Next i
Sheet2.[A2:E65000] = Mg2
Sheet2.[g3] = Timer - t
Application.ScreenUpdating = True
End Sub

 

[concogia]

Hi, Code mảng của Ptm 0412 khá ngon rồi, nhưng vì ấn tượng về tốc độ nên mình cũng thử viết lại bằng mảng xem sao? Để có thể vượt qua giới hạn của anh Ptm 0412 mình phải loay hoay mất đúng buổi tối qua. Cuối cùng mình cũng vượt qua giới hạn của Ptm0412 là 0,67s còn 0,48s. Code của mình thế này (Đúng là dùng mảng so với dùng Cell thì kết quả như mơ)

Sub chuyen3()
Dim Mg1, Mg2(), Cty
Dim i, j, n, m, m1
Application.ScreenUpdating = False
t = Timer
Mg1 = Range([A5], [A5].SpecialCells(xlLastCell))
Cty = [A4].Resize(, UBound(Mg1, 2))
j = 1
n = 2
ReDim Mg2(1 To 65000, 1 To 5)
For i = 1 To UBound(Mg1, 1)
Mg2(j, 1) = Mg1(i, 1)
Mg2(j, 2) = Mg1(i, 2)
j = j + 1
For m = 3 To UBound(Mg1, 2) Step 4
If Mg1(i, m) <> "" Then
For m1 = 0 To 3
If n = 2 Then
Mg2(j, 2) = Cty(1, m)
Else
Mg2(j, n) = Mg1(i, m + m1)
End If
n = n + 1
If n = 6 Then
n = 2
j = j + 1
End If
Next m1
End If
Next m
Next i
Sheet2.[A2:E65000] = Mg2
Sheet2.[g3] = Timer - t
Application.ScreenUpdating = True
End Sub

Tham gia "zí" Thầy Sealand một em nữa

Private Sub CommandButton4_Click()
Dim Vung, TenCt, I As Long, J As Long, Mg(), K As Long, Tg As Double
    Tg = Timer
    TenCt = [a4:v4].Value:    K = 1
    Vung = Range([a5], [a50000].End(xlUp)).Resize(, 22).Value
        ReDim Mg(1 To UBound(Vung) * 7, 1 To 5)
            For I = 1 To UBound(Vung)
                Mg(K, 1) = Vung(I, 1): Mg(K, 2) = Vung(I, 2)
                K = K + 1
                    For J = 3 To 19 Step 4
                        If Vung(I, J) <> vbNullString Then
                            Mg(K, 2) = TenCt(1, J): Mg(K, 3) = Vung(I, J + 1)
                            Mg(K, 4) = Vung(I, J + 2): Mg(K, 5) = Vung(I, J + 3): K = K + 1
                        End If
                    Next J
            Next I
    With Sheets("Ketqua")
        .[n2].Resize(K, 5) = Mg
        .[g4] = Timer - Tg
    End With
End Sub

 

[ptm0412]

Code Cò già nhanh nhất (hic)
Nhưng Cò thử sửa theo điều kiện chưa biết trước số lượng công ty là bao nhiêu, và không biết cột cuối là cột nào xem? Vì ngoại trừ chỗ đó thì so với code của mình nó y chang thuật toán, tất tần tật? (Trừ 1 mảng Tenct mới thêm vào)

Code sealand thì có cải tiến dùng thêm 1 vòng lặp nhưng chưa hiểu tại sao sự khác biệt này có thể cải thiện tốc độ? Có lẽ do đã dùng thêm 1 mảng Cty?

______________

Chính xác thì chính là nhờ thêm 1 mảng Cty mà code sealand nhanh hơn. (Đã test với code ptm thêm 1 mảng giống vậy, 2 code nhanh như nhau)

 

[concogia]

Code Cò già nhanh nhất (hic)
Nhưng Cò thử sửa theo điều kiện chưa biết trước số lượng công ty là bao nhiêu, và không biết cột cuối là cột nào xem? Vì ngoại trừ chỗ đó thì so với code của mình nó y chang thuật toán, tất tần tật? (Trừ 1 mảng Tenct mới thêm vào)

Code sealand thì có cải tiến dùng thêm 1 vòng lặp nhưng chưa hiểu tại sao sự khác biệt này có thể cải thiện tốc độ? Có lẽ do đã dùng thêm 1 mảng Cty?

______________

Chính xác thì chính là nhờ thêm 1 mảng Cty mà code sealand nhanh hơn. (Đã test với code ptm thêm 1 mảng giống vậy, 2 code nhanh như nhau)

Thấy các Thầy tham gia vui quá nên góp vui thôi chứ Cò nghĩ tốc độ kg quan trọng lắm, miễn kết quả OK và tốc độ tương đối _ đừng phải uống mấy ly cafe & 1/2 gói thuốc _ là được rồi
Chúc Thầy ptm & Thầy Sealand vui khỏe, càng ngày càng nhiều bài bổ ích cho diễn đàn

 

[infotech]

Tham gia "zí" Thầy Sealand một em nữa

Private Sub CommandButton4_Click()
Dim Vung, TenCt, I As Long, J As Long, Mg(), K As Long, Tg As Double
    Tg = Timer
    TenCt = [a4:v4].Value:    K = 1
    Vung = Range([a5], [a50000].End(xlUp)).Resize(, 22).Value
        ReDim Mg(1 To UBound(Vung) * 7, 1 To 5)
            For I = 1 To UBound(Vung)
                Mg(K, 1) = Vung(I, 1): Mg(K, 2) = Vung(I, 2)
                K = K + 1
                    For J = 3 To 19 Step 4
                        If Vung(I, J) <> vbNullString Then
                            Mg(K, 2) = TenCt(1, J): Mg(K, 3) = Vung(I, J + 1)
                            Mg(K, 4) = Vung(I, J + 2): Mg(K, 5) = Vung(I, J + 3): K = K + 1
                        End If
                    Next J
            Next I
    With Sheets("Ketqua")
        .[n2].Resize(K, 5) = Mg
        .[g4] = Timer - Tg
    End With
End Sub

Cảm ơn hai bạn Sealand và bák concoga, nhưng mà chưa hiểu code lắm