20170621xlVBA跨表转换数据

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61

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