Sub 跨表轉置()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Rng As Range
    Dim Index As Long

    Const HeadRow As Long = 12
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("模板")
    Set oSht = Wb.Worksheets("數據表")

    With Sht
        .UsedRange.Offset(HeadRow).ClearContents
    End With

    With oSht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A3:O" & endrow)
        Index = HeadRow
        With Rng
            For i = 1 To .Rows.Count
                Index = Index + 1
                Sht.Cells(Index, "C").Value = .Cells(i, "A").Text    ‘姓名
                Sht.Cells(Index, "D").Value = "‘" & .Cells(i, "B").Text    ‘手機
                Sht.Cells(Index, "E").Value = "‘" & Replace(.Cells(i, "C").Text, "-", "/")    ‘生日
                Sht.Cells(Index, "F").Value = "‘" & .Cells(i, "D").Text    ‘證件號
                Sht.Cells(Index, "G").Value = Split(.Cells(i, "E").Text, " ")(0)    ‘證件類型
                Sht.Cells(Index, "H").Value = Split(.Cells(i, "F").Text, " ")(0)    ‘性別
                Sht.Cells(Index, "I").Value = Split(.Cells(i, "G").Text, " ")(0) & "型"   ‘血型
                Sht.Cells(Index, "J").Value = Split(.Cells(i, "H").Text, " ")(0)    ‘國際

                x = UBound(Split(.Cells(i, "H").Text, " "))
                If x >= 1 Then Sht.Cells(Index, "K").Value = Split(.Cells(i, "H").Text, " ")(1)
                If x >= 2 Then Sht.Cells(Index, "L").Value = Split(.Cells(i, "H").Text, " ")(2)
                If x = 3 Then Sht.Cells(Index, "M").Value = Split(.Cells(i, "H").Text, " ")(3)

                Sht.Cells(Index, "N").Value = Split(.Cells(i, "I").Text, " ")(0)    ‘項目
                Sht.Cells(Index, "O").Value = .Cells(i, "K").Text    ‘尺寸
                Sht.Cells(Index, "P").Value = .Cells(i, "L").Text    ‘地址
                Sht.Cells(Index, "Q").Value = .Cells(i, "M").Text    ‘郵箱

                Sht.Cells(Index, "S").Value = .Cells(i, "N").Text    ‘緊急聯系人
                Sht.Cells(Index, "T").Value = .Cells(i, "O").Text    ‘電話
                ‘  Sht.Cells(Index, "U").Value = "http://live.yongdongli.net/page/photo.php?n=" & .Cells(i, "A").Text
                addres = "http://live.yongdongli.net/page/photo.php?n=" & .Cells(i, "A").Text
                Sht.Hyperlinks.Add Anchor:=Sht.Cells(Index, "U"), Address:=addres, TextToDisplay:=addres

            Next i
        End With

    End With



    Set Wb = Nothing
    Set Sht = Nothing
    Set oSht = Nothing


End Sub

20170621xlVBA跨表轉換數據