行转置列

xuankun2013

请求高手帮忙给弄一下，我对宏只了解一点点，但整理数据太多。用宏快。谢谢

行数据转置列.zip (12.12 KB, 下载次数: 14)

2018-9-18 08:02 上传

点击文件名下载附件

hzruziniu

1. Private Sub CommandButton1_Click()
   
2.     For i = 26 To 36
   
3.         If Cells(i, 3) <> "" Then
   
4.             s = Split(Cells(i, 3), "-")(0)
   
5.             If Cells(i - 1, 3) = "" Then
   
6.                 p = 0
   
7.             Else
   
8.                 p = Split(Cells(i - 1, 3), "-")(0)
   
9.             End If
   
10.             If s <> p Then
    
11.                 ii = i
    
12.                 n = 4
    
13.                 Cells(ii, n) = Cells(i, 3)
    
14.             Else
    
15.                 n = n + 1
    
16.                 Cells(ii, n) = Cells(i, 3)
    
17.             End If
    
18.         End If
    
19.      Next
    
20. End Sub

复制代码

hzruziniu

行数据转置列.rar (20.88 KB, 下载次数: 24)

2018-9-18 09:45 上传

点击文件名下载附件

xuankun2013

您好，我怎么执行没有反应，我可能没有表达明白，第一步是先将D到L列超链接数值转置对应的A列，第二步将参照A列，自动显示序列号，第三步将序列号，转置到对应的D-L区域，呵呵

xiangbaoan

……仅供参考……

xiangbaoan

Option Explicit
Sub test()
Dim ar, tp, r&, c%, k&, t&, n%, y&
Application.ScreenUpdating = False
With Sheet1
    ar = .[a1:l6]
    ReDim tp(1 To 9999, 1 To UBound(ar, 2))
    k = 1
    For c = 1 To 12
        tp(k, c) = ar(k, c)
    Next
    tp(k, 2) = "转置"
    t = 0
    For r = 2 To UBound(ar)
        k = k + 1
        y = k
        tp(k, 1) = ar(r, 1)
        n = 0
        For c = 4 To UBound(ar, 2)
            If Len(ar(r, c)) Then n = n + 1
        Next
        If n Then t = t + 1
        n = 0
        For c = 4 To UBound(ar, 2)
            If Len(ar(r, c)) Then
                n = n + 1
                tp(k, 1) = ar(r, 1)
                tp(k, 2) = ar(r, c) & "\" & .Cells(r, c).Hyperlinks(1).Address
                If n Then tp(y, n + 3) = "'" & t & "-" & n
                If n Then tp(k, 3) = "'" & t & "-" & n
                k = k + 1
            End If
        Next
        If n Then k = k - 1
    Next
End With
With Sheet2
    .Cells.Clear
    .[a1].Resize(k, 12) = tp
    For r = 2 To k
        If Len(tp(r, 2)) Then
                .Cells(r, 2).Hyperlinks.Add .Cells(r, 2), Split(tp(r, 2), "\")(1), , , Split(tp(r, 2), "\")(0)
        End If
    Next
    With .UsedRange
        .Font.Underline = -4142
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
    End With
    .[a:l].EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub

liulang0808

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ActiveSheet
   
4.     arr = sh.[a1].Resize(6, 12)
   
5.     With Sheets("结果")
   
6.         .UsedRange.Offset(1).ClearContents
   
7.         r = 2
   
8.         For j = 2 To UBound(arr)
   
9.             sh.Cells(j, 1).Resize(1, 12).Copy .Cells(r, 1)
   
10.             n = 0
    
11.             For i = 4 To UBound(arr, 2)
    
12.                 If Len(arr(j, i)) > 0 Then
    
13.                     If n = 0 Then
    
14.                         x = r
    
15.                         n = n + 1
    
16.                         .Cells(r, 3).NumberFormatLocal = "@"
    
17.                         .Cells(r, 3) = .Cells(r, 1) & "-1"
    
18.                         sh.Cells(j, i).Copy .Cells(r, 2)
    
19.                         .Cells(x, i).Hyperlinks.Delete
    
20.                         .Cells(x, i).NumberFormatLocal = "@"
    
21.                         .Cells(r, i) = .Cells(r, 3)
    
22.                     Else
    
23.                         n = n + 1
    
24.                         r = r + 1
    
25.                         .Cells(r, 1) = .Cells(r - 1, 1)
    
26.                         .Cells(r, 3).NumberFormatLocal = "@"
    
27.                         .Cells(r, 3) = .Cells(r, 1) & "-" & n
    
28.                         sh.Cells(j, i).Copy .Cells(r, 2)
    
29.                         .Cells(x, i).Hyperlinks.Delete
    
30.                         .Cells(x, i).NumberFormatLocal = "@"
    
31.                         .Cells(x, i) = .Cells(r, 3)
    
32.                     End If
    
33.                 End If
    
34.             Next i
    
35.             r = r + 1
    
36.         Next j
    
37.         With .UsedRange
    
38.             .HorizontalAlignment = xlCenter
    
39.             .VerticalAlignment = xlCenter
    
40.             .Borders.LineStyle = xlContinuous
    
41.         End With
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44. End Sub
    

复制代码

liulang0808

附件内容供参考，主要在于格式设置的。。。。

xuankun2013

收到。非常感谢，