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

[soledad_90]

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!

 

[snow25]

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é.

 

[VetMini]

Đã thử Unpivot của Power Pivot chưa?

 

[soledad_90]

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é.

Xin cảm ơn nhiều nhé!
File đính kèm đây ạ

Bài đã được tự động gộp: 1/9/20

Đã thử Unpivot của Power Pivot chưa?

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 ạ

 

[snow25]

Xin cảm ơn nhiều nhé!
File đính kèm đây ạ

Bài đã được tự động gộp: 1/9/20

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é.

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

 

[soledad_90]

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

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é

 

[manhhung291093]

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

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

 

[soledad_90]

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

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 ạ

 

[HUONGHCKT]

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 ạ

Trong khi chờ Anh Snow trả bài. thử xem cách cổ điển này thế nào.

 

[soledad_90]

Trong khi chờ Anh Snow trả bài. thử xem cách cổ điển này thế nào.

Em cảm ơn sự giúp đỡ từ anh ạ.
Code cho KQ đúng rồi ạ .