Xin giúp đỡ về chuyển dữ liệu các Cột thành các Hàng

[micanto269]

Chào anh chị em diễn đàn, Tớ đang luẩn quẩn với vụ EXCEL này xin nhờ mọi người chỉ giáo.

Sheet 1:
-----------------------------------------
Họ tên______________ngoai_ngu

Đinh Hoa Bộ_________Pháp
Đinh Hoa Bộ_________Anh
Nguyễn Thị Chiêm____Anh
Nguyễn Thị Chiêm____Nga
Nguyễn Thị Chiêm____Lào
Phạm Văn Ruyền_____Anh
Nguyễn Quang Anh___Anh
Nguyễn Quang Anh___Ý
-----------------------------------------

Giờ tớ muốn nó chuyển thành Sheet 2 như sau
-----------------------------------------
Họ tên______________ngoai_ngu 1_______ngoai ngu 2_________ngoai ngu 3

Đinh Hoa Bộ_________Pháp_____________Anh
Nguyễn Thị Chiêm____Anh______________Nga________________Lào
Phạm Văn Ruyền_____Anh
Nguyễn Quang Anh___Anh______________Ý
-----------------------------------------

Danh sách của tớ có khoảng 100 người với số lượng ngoại ngữ của từng người biết là 1, 2, 3, hoặc 4 ngoại ngữ.

Xin đa tạ./.

 

[SA_DQ]

Bạn xài macro sau, nha

[COLOR="Blue"]Option Explicit
[B]Sub NgoaiNgu()[/B]
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range, Rg0 As Range, Clls As Range
 Dim MyAdd As String:                           Dim Dg As Long
 
 Set Sh = Sheets("S2"):                         Sheets("S1").Select
 Application.ScreenUpdating = False
 Sh.[B1].CurrentRegion.Offset(, 1).ClearContents
 Sh.[A1] = "STT":                               Sh.[B1].Value = [A1].Value
 Columns("A:B").Insert Shift:=xlToRight:
 Columns("D:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[B1], Unique:=True
 Range("B2:B" & [B65500].End(xlUp).Row).Copy
 Sh.[C1].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
 ActiveWorkbook.Names("Extract").Delete
 Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[A1], Unique:=True
 
 Set Rng = Range([C1], [C65500].End(xlUp))
 Set Rg0 = Sh.[C1].Resize(, [B65500].End(xlUp).Row)
 For Each Clls In Range([A2], [A65500].End(xlUp))
   Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then
      MyAdd = sRng.Address:                     Dg = Sh.[B65500].End(xlUp).Offset(1).Row
      Do
         For Each Cls In Rg0
            If Cls = sRng.Offset(, 1).Value Then
               Sh.Cells(Dg, Cls.Column).Value = "X"
               Exit For
            End If
         Next Cls
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      Sh.Cells(Dg, "B").Value = Clls.Value
   End If
 Next Clls
 Columns("A:B").Delete Shift:=xlToLeft:         Sh.Select
[B]End Sub[/B][/COLOR]

 

[atmt17]

Tặng bạn 2 UDF xài chơi!

Function UniqueList(SrcArray, Pos As Long) As String
  Dim Temp, elm
  Temp = SrcArray
  With CreateObject("Scripting.Dictionary")
    For Each elm In Temp
      If elm <> "" And Not .Exists(elm) Then
        .Add elm, "": Pos = Pos - 1
        If Pos = 0 Then
          UniqueList = elm: Exit Function
        End If
      End If
    Next elm
  End With
End Function

Function FindSpec(FVal, SrcArray, ColIndex As Long)
  Dim Item, Temp, Arr(1 To 100) As String, i As Long, j As Long
  Temp = SrcArray
  On Error Resume Next
  For i = LBound(Temp) To UBound(Temp)
    If Temp(i, LBound(Temp)) = FVal Then
      j = j + 1
      Arr(j) = Temp(i, ColIndex)
    End If
  Next
  FindSpec = Arr
End Function

Giả sử dữ liệu gốc nằm tại sheet1. Vậy tại sheet2, bạn gõ các công thức sau:
- Cell A2, gõ công thức

=UniqueList(Sheet1!$A$2:$A$1000,ROWS($1:1))

kéo fill xuống
- Quét chọn B2:E2 rồi gõ vào thanh Formula công thức:

=FindSpec($A2,Sheet1!$A$1:$B$1000,2)

Bấm tổ hợp phím Ctrl + Shift + Enter để kết thúc. Tiếp theo kéo fill B2:E2 xuống

 

[micanto269]

Xin đa tạ các túc hạ cao thủ võ lâm. Tình hình là rất bổ ích cho tại hạ này. Kiểu này phải bố trí thu nạp ít võ công VB để bằng anh bằng em mới được,

 

[atmt17]

Thêm 1 cách khác

Gữi tặng bạn thêm 1 cách làm khác (hơi bị độc à nha)

Sub Transfer(SrcRng As Range, ColIndex As Long, Target As Range)
  Dim Arr(1 To 10000, 1 To 200), Temp, Tmp1, Tmp2, Func As WorksheetFunction
  Dim i As Long, n As Long, m As Long, k As Long, iMax As Long
  Temp = SrcRng.Value
  Set Func = Application.WorksheetFunction
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Temp)
      If Temp(i, 1) <> "" Then
        Tmp1 = Temp(i, 1): Tmp2 = Temp(i, ColIndex)
        If Not .Exists(Tmp1) Then
          n = n + 1
          .Add Tmp1, 2
          Arr(n, 1) = Tmp1: Arr(n, 2) = Tmp2
        Else
          m = Func.Match(Tmp1, .Keys, 0)
          .Item(Tmp1) = .Item(Tmp1) + 1
          Arr(m, .Item(Tmp1)) = Tmp2
        End If
        If iMax < .Item(Tmp1) Then iMax = .Item(Tmp1)
      End If
    Next
  End With
  Target.Resize(n, iMax) = Arr
End Sub

Sub Main()
  Dim SrcRng As Range, Target As Range
  Set SrcRng = Sheet1.Range("A2:C1000")
  Set Target = Sheet2.Range("A2")
  Transfer SrcRng, 2, Target
End Sub

Mở file đính kèm, bấm nút và xem kết quả

 

[micanto269]

Chà chà. Pro ghê nhỉ. Đúng là tốc độ nhanh hơn hẳn bác ạ. Để em xem có gì ứng dụng thêm được cái này xin được chỉ giáo sau. Thanks bác nhiều