Xin giúp đỡ file Excel chuyển đổi định dạng hàng ngang sang cột dọc

Liên hệ QC

soledad_90

Thành viên thường trực
Tham gia
12/1/10
Bài viết
250
Được thích
43
Giới tính
Nam
Em xin chào diễn đàn!

Em có file excel mẫu , file đính kèm có dẫn chứng cần thay đổi
Do trước đây mình theo giõi Excel nên thể hiện hàng ngang dữ liệu, nhưng sau khi chuyển qua phần mềm thì cần Y/c dữ liệu ở dạng cột dọc
Vậy xin hướng dẫn của diễn đàn ạ.
Em xin cảm ơn!
 

File đính kèm

  • Ví dụ.xls
    31.5 KB · Đọc: 20
Em xin chào diễn đàn!

Em có file excel mẫu , file đính kèm có dẫn chứng cần thay đổi
Do trước đây mình theo giõi Excel nên thể hiện hàng ngang dữ liệu, nhưng sau khi chuyển qua phần mềm thì cần Y/c dữ liệu ở dạng cột dọc
Vậy xin hướng dẫn của diễn đàn ạ.
Em xin cảm ơn!
Dùng VBA không bạn.Nếu dùng bạn gửi file thực tế của bạn mình code cho nhé.
 
Đã thử Unpivot của Power Pivot chưa?
 

File đính kèm

  • 200901_Tuvis loại A_thực tồn.xls
    96.5 KB · Đọc: 14
Xin cảm ơn nhiều nhé!
File đính kèm đây ạ
Bài đã được tự động gộp:


Em mới biết sử dụng Pivot Table còn Unpivot thì chưa biết sử sụng.
Xin nhận sự chỉ dẫn ạ
Bạn thử code này nhé.
Mã:
Sub chuyendoi()
    Dim arr, kq, i As Long, lr As Long, a As Long, j As Long
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:Y" & lr).Value
         ReDim kq(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
   End With
        For i = 2 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                If arr(i, j) > 0 Then
                   a = a + 1
                   kq(a, 1) = arr(i, 1)
                   kq(a, 2) = arr(i, 2)
                   kq(a, 3) = arr(1, j)
                   kq(a, 4) = arr(i, j)
                End If
            Next j
       Next i
  With Sheets("sheet2")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 2 Then .Range("A2:D" & lr).ClearContents
       If a Then
          .Range("A2:D2").Resize(a).Value = kq
       End If
  End With
End Sub
 

File đính kèm

  • 200901_Tuvis loại A_thực tồn.xlsm
    47.8 KB · Đọc: 20
Bạn thử code này nhé.
Mã:
Sub chuyendoi()
    Dim arr, kq, i As Long, lr As Long, a As Long, j As Long
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:Y" & lr).Value
         ReDim kq(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
   End With
        For i = 2 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                If arr(i, j) > 0 Then
                   a = a + 1
                   kq(a, 1) = arr(i, 1)
                   kq(a, 2) = arr(i, 2)
                   kq(a, 3) = arr(1, j)
                   kq(a, 4) = arr(i, j)
                End If
            Next j
       Next i
  With Sheets("sheet2")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 2 Then .Range("A2:D" & lr).ClearContents
       If a Then
          .Range("A2:D2").Resize(a).Value = kq
       End If
  End With
End Sub
Xin cảm ơn bạn nhiều nhé
 
Bạn thử code này nhé.
Mã:
Sub chuyendoi()
    Dim arr, kq, i As Long, lr As Long, a As Long, j As Long
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:Y" & lr).Value
         ReDim kq(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
   End With
        For i = 2 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                If arr(i, j) > 0 Then
                   a = a + 1
                   kq(a, 1) = arr(i, 1)
                   kq(a, 2) = arr(i, 2)
                   kq(a, 3) = arr(1, j)
                   kq(a, 4) = arr(i, j)
                End If
            Next j
       Next i
  With Sheets("sheet2")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 2 Then .Range("A2:D" & lr).ClearContents
       If a Then
          .Range("A2:D2").Resize(a).Value = kq
       End If
  End With
End Sub
Chào bạn. thấy code của bạn rất hay. Mình xin mượn áp dụng. Thanks bạn nhiều. Mình không biết về code nên xin hỏi muốn thêm 1 cột cố định tại sheet 2 khi lấy dữ liệu từ sheet 1 qua thì phải chỉnh code như thế nào.
Cám ơn bạn rất nhiều
 
Bạn thử code này nhé.
Mã:
Sub chuyendoi()
    Dim arr, kq, i As Long, lr As Long, a As Long, j As Long
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:Y" & lr).Value
         ReDim kq(1 To UBound(arr) * UBound(arr, 2), 1 To 4)
   End With
        For i = 2 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                If arr(i, j) > 0 Then
                   a = a + 1
                   kq(a, 1) = arr(i, 1)
                   kq(a, 2) = arr(i, 2)
                   kq(a, 3) = arr(1, j)
                   kq(a, 4) = arr(i, j)
                End If
            Next j
       Next i
  With Sheets("sheet2")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 2 Then .Range("A2:D" & lr).ClearContents
       If a Then
          .Range("A2:D2").Resize(a).Value = kq
       End If
  End With
End Sub
Em xin nhờ anh giúp đỡ thêm cho việc chuyển đổi định dạng ạ.
Khi dữ liệu gốc có thay đổi . Em có đính kèm theo file.
Em cảm ơn ạ
 

File đính kèm

  • 220624_SPG chuyen doi.xlsm
    34.1 KB · Đọc: 4

File đính kèm

  • 220624_SPG chuyen doi.xlsm
    45 KB · Đọc: 10
Web KT
Back
Top Bottom