Chuyển dữ liệu từ dọc sang ngang (2 người xem)

[luonghoanghr]

Mình có file dữ liệu người thân cần chuyển từ dọc sang ngang để thực hiện các nghiêp vụ liên quan, các ACE xem dùng giải pháp nào để xử lý với ạ.

Cụ thể là bên sheet dữ liệu gốc là file mình đang nhập và bên sheet dữ liệu chuyển là file cuối cùng mình muốn đổ dữ liệu sang.

Mình cảm ơn nhiều ạ

 

[snow25]

Mình có file dữ liệu người thân cần chuyển từ dọc sang ngang để thực hiện các nghiêp vụ liên quan, các ACE xem dùng giải pháp nào để xử lý với ạ.

Cụ thể là bên sheet dữ liệu gốc là file mình đang nhập và bên sheet dữ liệu chuyển là file cuối cùng mình muốn đổ dữ liệu sang.

Mình cảm ơn nhiều ạ

Bạn xem nhé.Dùng VBA.

Sub chuyendulieu()
    Dim arr, i As Long, j As Long, lr As Long, dic As Object, kq, dk As String, dks As String, a As Long, b As Long, c As Integer, d As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Du lieu chuyen")
         arr = .Range("A1:Y1").Value
         For i = 3 To UBound(arr, 2)
             dic.Item(arr(1, i)) = i
         Next i
   End With
   With Sheets("Du lieu goc")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:F" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To i - 1)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, Array(a, 0)
               kq(a, 1) = dk
               kq(a, 2) = arr(i, 2)
            End If
               b = dic.Item(dk)(0)
               If arr(i, 4) = "Con ru" & ChrW(7897) & "t" Then
                  c = dic.Item(dk)(1) + 1
                  dks = arr(i, 4) & " " & c
                  dic.Item(dk) = Array(b, c)
                  d = dic.Item(dks)
                  kq(a, d) = arr(i, 3)
                  kq(a, d + 1) = arr(i, 6)
                  kq(a, d + 2) = arr(i, 5)
               Else
                  dks = arr(i, 4)
                  d = dic.Item(dks)
                  If d Then
                  kq(a, d) = arr(i, 3)
                  kq(a, d + 1) = arr(i, 5)
                  End If
               End If
      Next i
  End With
  With Sheets("Du lieu chuyen")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 1 Then .Range("A2:Y" & lr).ClearContents
       If a Then .Range("A2:Y2").Resize(a).Value = kq
  End With
End Sub

 

[luonghoanghr]

Bạn xem nhé.Dùng VBA.

Sub chuyendulieu()
    Dim arr, i As Long, j As Long, lr As Long, dic As Object, kq, dk As String, dks As String, a As Long, b As Long, c As Integer, d As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Du lieu chuyen")
         arr = .Range("A1:Y1").Value
         For i = 3 To UBound(arr, 2)
             dic.Item(arr(1, i)) = i
         Next i
   End With
   With Sheets("Du lieu goc")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:F" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To i - 1)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, Array(a, 0)
               kq(a, 1) = dk
               kq(a, 2) = arr(i, 2)
            End If
               b = dic.Item(dk)(0)
               If arr(i, 4) = "Con ru" & ChrW(7897) & "t" Then
                  c = dic.Item(dk)(1) + 1
                  dks = arr(i, 4) & " " & c
                  dic.Item(dk) = Array(b, c)
                  d = dic.Item(dks)
                  kq(a, d) = arr(i, 3)
                  kq(a, d + 1) = arr(i, 6)
                  kq(a, d + 2) = arr(i, 5)
               Else
                  dks = arr(i, 4)
                  d = dic.Item(dks)
                  If d Then
                  kq(a, d) = arr(i, 3)
                  kq(a, d + 1) = arr(i, 5)
                  End If
               End If
      Next i
  End With
  With Sheets("Du lieu chuyen")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 1 Then .Range("A2:Y" & lr).ClearContents
       If a Then .Range("A2:Y2").Resize(a).Value = kq
  End With
End Sub