20170621xlVBA跨表转换数据

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