Chuyển đổi trình bày danh sách từ dọc sang dàn ngang

[Excel my love_1]

Em chào các anh chị của giải pháp excel. Em có danh sách số chứng từ và người sử dụng trình bày theo dạng dọc , nay em muốn trình bày dàn ngang ra trên bảng tính
Em nhờ các anh chị giúp em code để thực hiện việc này
Chi tiết em trình bày trong tập tin gửi kèm
Em cảm ơn các anh chị đã đọc bài của em có gì nhẹ tay cho em (vì em mới viết bài, mặc dù em đã đọc nhiều bài, thấy nhiều bạn mới viết bị phê bình dữ lắm)

 

[hoangexcell]

Em chào các anh chị của giải pháp excel. Em có danh sách số chứng từ và người sử dụng trình bày theo dạng dọc , nay em muốn trình bày dàn ngang ra trên bảng tính
Em nhờ các anh chị giúp em code để thực hiện việc này
Chi tiết em trình bày trong tập tin gửi kèm
Em cảm ơn các anh chị đã đọc bài của em có gì nhẹ tay cho em (vì em mới viết bài, mặc dù em đã đọc nhiều bài, thấy nhiều bạn mới viết bị phê bình dữ lắm)

haha xin phép hỏi lý do vì sao bạn cần phải chuyển qua ngang như vậy?

 

[CHAOQUAY]

Em chào các anh chị của giải pháp excel. Em có danh sách số chứng từ và người sử dụng trình bày theo dạng dọc , nay em muốn trình bày dàn ngang ra trên bảng tính
Em nhờ các anh chị giúp em code để thực hiện việc này
Chi tiết em trình bày trong tập tin gửi kèm
Em cảm ơn các anh chị đã đọc bài của em có gì nhẹ tay cho em (vì em mới viết bài, mặc dù em đã đọc nhiều bài, thấy nhiều bạn mới viết bị phê bình dữ lắm)

Sub Doc_Ngang()
Dim Nguon
Dim Kq
Dim i, j, k, x, z, t
Nguon = Sheet2.Range("A1").CurrentRegion
t = UBound(Nguon)
For i = 1 To t
    If IsNumeric(Nguon(i, 1)) Then
        z = z + 1
        If k < Nguon(i, 1) Then k = Nguon(i, 1)
    End If
Next i
ReDim Kq(1 To k + 2, 1 To z * 2)
x = 1
j = 1
Kq(1, 1) = Nguon(1, 1)
Kq(1, 2) = Nguon(1, 2)
For i = 2 To t
    x = x + 1
    Kq(x, j) = Nguon(i, 1)
    Kq(x, j + 1) = Nguon(i, 2)
    If IsNumeric(Nguon(i, 1)) Then
        If i = t Then
            Exit For
        Else
            x = 1
            j = j+2
            Kq(1, j) = Nguon(1, 1)
            Kq(1, j + 1) = Nguon(1, 2)
        End If
    End If
Next i
With Sheet3
    .UsedRange.ClearContents
    .Range("A1").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
    .UsedRange.Columns.AutoFit
End With
End Sub

 

[HieuCD]

Em chào các anh chị của giải pháp excel. Em có danh sách số chứng từ và người sử dụng trình bày theo dạng dọc , nay em muốn trình bày dàn ngang ra trên bảng tính
Em nhờ các anh chị giúp em code để thực hiện việc này
Chi tiết em trình bày trong tập tin gửi kèm
Em cảm ơn các anh chị đã đọc bài của em có gì nhẹ tay cho em (vì em mới viết bài, mặc dù em đã đọc nhiều bài, thấy nhiều bạn mới viết bị phê bình dữ lắm)

Cách khác

Sub Dong_Cot()
  Dim sArr(), Res(), sRow&, i&, k&, jCol&
  With Sheet2
    sRow = .Range("B" & Rows.Count).End(xlUp).Row
    sArr = .Range("A1:B" & sRow).Value
  End With
  For i = 2 To sRow
    If IsNumeric(sArr(i, 1)) Then
      jCol = jCol + 2
    End If
  Next i
  ReDim Res(1 To sRow, 1 To jCol)
  k = 1: jCol = 0
  For i = 2 To sRow
    k = k + 1
    Res(k, jCol + 1) = sArr(i, 1)
    Res(k, jCol + 2) = sArr(i, 2)
    If IsNumeric(sArr(i, 1)) Then
      Res(1, jCol + 1) = sArr(1, 1)
      Res(1, jCol + 2) = sArr(1, 2)
      k = 1:      jCol = jCol + 2
    End If
  Next i
  Sheet1.UsedRange.ClearContents
  Sheet1.Range("A1").Resize(sRow, jCol) = Res
End Sub

 

[killer8725]

Bạn thử code này xem nhé.

Option Explicit

Sub Ngang_doc()

Dim Dic1 As Object
Dim pList As Variant
Dim xList As Variant
Dim sValue As String
Dim tValue As String
Dim LastRow As Long
Dim iRow As Long
Dim i, j As Long

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

'khai bao dictionary
Set Dic1 = CreateObject("Scripting.dictionary")

'tim dong cuoi co du lieu
LastRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row

'xoa du lieu cu
Sheets("Sheet2").Range("E1:XFD" & LastRow).ClearContents

'gan gia tri cho pList
pList = Sheets("Sheet2").Range("A2:B" & LastRow)

'gan gia tri cho Dictionary
i = 1
For iRow = 1 To UBound(pList, 1)
sValue = CStr(pList(iRow, 2))
tValue = CStr(pList(iRow, 1))

If Not Dic1.Exists(sValue) Then
i = i + 1
Dic1.Item(sValue) = i
Cells(1, 2 * i + 1) = Cells(1, 1)
Cells(1, 2 * i + 2) = Cells(1, 2)
Cells(2, 2 * i + 1) = tValue
Cells(2, 2 * i + 2) = sValue
j = 2
Else
j = j + 1
Cells(j, 2 * i + 1) = tValue
Cells(j, 2 * i + 2) = sValue
End If

Next iRow








Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

 

[1convit789]

Em chào các anh chị của giải pháp excel. Em có danh sách số chứng từ và người sử dụng trình bày theo dạng dọc , nay em muốn trình bày dàn ngang ra trên bảng tính
Em nhờ các anh chị giúp em code để thực hiện việc này
Chi tiết em trình bày trong tập tin gửi kèm
Em cảm ơn các anh chị đã đọc bài của em có gì nhẹ tay cho em (vì em mới viết bài, mặc dù em đã đọc nhiều bài, thấy nhiều bạn mới viết bị phê bình dữ lắm)

bạn dùng hàm TRANSPOSE nha!
ví dụ
Chuyển 2 hàng 3 cột thành 2 cột 3 hàng
=TRANSPOSE() sau đó nhấn ctr + shilft + enter

 

[Excel my love_1]

haha xin phép hỏi lý do vì sao bạn cần phải chuyển qua ngang như vậy?

Cảm ơn anh đã quan tâm; file này em sẽ gửi mail cho 1 Người phụ trách của nhóm người nằm trong list trên, em muốn để dạng trình bày ngang; để giúp cho Người phụ trách đó sẽ nhanh chóng tiếp cận thông tin và làm việc với những thành viên có tên trong nhóm.

Bài đã được tự động gộp: 12/11/19

bạn dùng hàm TRANSPOSE nha!
ví dụ
Chuyển 2 hàng 3 cột thành 2 cột 3 hàng
=TRANSPOSE() sau đó nhấn ctr + shilft + enter

Cảm ơn bạn, của mình là muốn ra n cột dựa vào tên của Cột Người sử dụng bạn à

 

[Excel my love_1]

Em cảm ơn các anh và các bạn đã giúp đỡ
Code của các anh Chaoquay; anh HieuCD và anh killer8725 đều ra đúng kết quả em mong đợt
Đặc biệt code của anh HieuCD và anh killer8725 không những ra đúng mà còn trên cả mong đợi của em (code các anh tuyệt vời ở chỗ ko dựa vào các đoạn đếm số lượng (Counta(Ax:Ay) ở cột chứng từ gốc, vì phần công thức Counta đó là em làm thủ công cũng hơi gà mờ, nhỡ mà em làm sót; mà code dựa vào chỗ đó để chạy thì chắc sẽ bị lỗi - cái này em phát hiện khi chạy code của anh Chaoquay, còn của anh HieuCD và Killer8725 thì hình như không phụ thuộc điểm này)

 

[HieuCD]

Em cảm ơn các anh và các bạn đã giúp đỡ
Code của các anh Chaoquay; anh HieuCD và anh killer8725 đều ra đúng kết quả em mong đợt
Đặc biệt code của anh HieuCD và anh killer8725 không những ra đúng mà còn trên cả mong đợi của em (code các anh tuyệt vời ở chỗ ko dựa vào các đoạn đếm số lượng (Counta(Ax:Ay) ở cột chứng từ gốc, vì phần công thức Counta đó là em làm thủ công cũng hơi gà mờ, nhỡ mà em làm sót; mà code dựa vào chỗ đó để chạy thì chắc sẽ bị lỗi - cái này em phát hiện khi chạy code của anh Chaoquay, còn của anh HieuCD và Killer8725 thì hình như không phụ thuộc điểm này)

Mình không để ý hàm counta, Chỉnh lại đếm luôn số lượng
Res(1, jCol + 1) = k - 2

Sub Dong_Cot()
  Dim sArr(), Res(), sRow&, i&, k&, jCol&
  With Sheet2
    sRow = .Range("B" & Rows.Count).End(xlUp).Row
    sArr = .Range("A1:B" & sRow).Value
  End With
  For i = 2 To sRow
    If IsNumeric(sArr(i, 1)) Then
      jCol = jCol + 2
    End If
  Next i
  ReDim Res(1 To sRow, 1 To jCol)
  k = 1: jCol = 0
  For i = 2 To sRow
    k = k + 1
    Res(k, jCol + 1) = sArr(i, 1)
    Res(k, jCol + 2) = sArr(i, 2)
    If IsNumeric(sArr(i, 1)) Then
      Res(1, jCol + 1) = k - 2
      Res(1, jCol + 2) = sArr(1, 2)
      k = 1:      jCol = jCol + 2
    End If
  Next i
  Sheet1.UsedRange.ClearContents
  Sheet1.Range("A1").Resize(sRow, jCol) = Res
End Sub

 

[Excel my love_1]

Mình không để ý hàm counta, Chỉnh lại đếm luôn số lượng
Res(1, jCol + 1) = k - 2

Em cảm ơn anh. Anh ơi! anh giúp em chỉnh cái dòng số 1 trong đoạn Res(1, jCol + 1) = k - 2, sao cho nó là dòng cuối của mỗi cột số chứng từ được không ạ. Ý em là muốn cái số lượng đếm ấy nằm ở dòng cuối của mỗi cột, thay vì là ở dòng đầu như code này anh à.
Em táy máy thay thử số 1 ở Res(1, jCol + 1) = k - 2; thành => Res(k, jCol + 1) = k - 2; nhưng mà cũng không được như ý lắm (vì nó mất luôn tiêu đề Số chứng từ) anh à.

 

[hoangexcell]

Cảm ơn anh đã quan tâm; file này em sẽ gửi mail cho 1 Người phụ trách của nhóm người nằm trong list trên

Hiểu nhu cầu rồi. Vậy thì bạn làm bằng cách khác thay vì phải Mắc Cro. Dù sao đã có Macro thôi thì sài đi hihi

 

[HieuCD]

Em cảm ơn anh. Anh ơi! anh giúp em chỉnh cái dòng số 1 trong đoạn Res(1, jCol + 1) = k - 2, sao cho nó là dòng cuối của mỗi cột số chứng từ được không ạ. Ý em là muốn cái số lượng đếm ấy nằm ở dòng cuối của mỗi cột, thay vì là ở dòng đầu như code này anh à.
Em táy máy thay thử số 1 ở Res(1, jCol + 1) = k - 2; thành => Res(k, jCol + 1) = k - 2; nhưng mà cũng không được như ý lắm (vì nó mất luôn tiêu đề Số chứng từ) anh à.

hỉnh lại

Sub Dong_Cot()
  Dim sArr(), Res(), sRow&, i&, k&, jCol&
  With Sheet2
    sRow = .Range("B" & Rows.Count).End(xlUp).Row
    sArr = .Range("A1:B" & sRow).Value
  End With
  For i = 2 To sRow
    If IsNumeric(sArr(i, 1)) Then
      jCol = jCol + 2
    End If
  Next i
  ReDim Res(1 To sRow, 1 To jCol)
  k = 1: jCol = 0
  For i = 2 To sRow
    k = k + 1
    Res(k, jCol + 1) = sArr(i, 1)
    Res(k, jCol + 2) = sArr(i, 2)
    If IsNumeric(sArr(i, 1)) Then
      Res(k, jCol + 1) = k - 2
      Res(1, jCol + 1) = sArr(1, 1)
      Res(1, jCol + 2) = sArr(1, 2)
      k = 1:      jCol = jCol + 2
    End If
  Next i
  Sheet1.UsedRange.ClearContents
  Sheet1.Range("A1").Resize(sRow, jCol) = Res
End Sub

 

[Excel my love_1]

hỉnh lại

Sub Dong_Cot()
......................
      Res(k, jCol + 1) = k - 2
      Res(1, jCol + 1) = sArr(1, 1)
      Res(1, jCol + 2) = sArr(1, 2)
......................
End Sub

Em cảm ơn anh nhiều nhiều ạ. Code ra đúng rồi anh à. Thật tuyệt vời. Em thấy các Web của Việt Nam về Excel; vềVBA ; thì có Giải pháp excel là trang web mạnh nhất. Em cũng tính tự nghiên cứu VBA mà tìm kiếm trên google, thấy có web lại nói về giaiphapexcel nhiều, nên em lựa chọn https://www.giaiphapexcel.com/