求助，求老司机带路，求VBA代码实现Sheet1曲线数据汇总到Sheet2，谢谢！

xiangbaoan

你发消息是指这一帖吗?

心云德乐

xiangbaoan 发表于 2019-11-21 16:37
你发消息是指这一帖吗?

是的，您好厉害！请高手帮忙看看贴子：求助，求老司机带路，求VBA代码实现Sheet1曲线数据汇总到Sheet2，谢谢！
我想把代码从最底行向上曲线取数据。我的水平修改不了贴子，

心云德乐

xiangbaoan 发表于 2019-11-21 16:32
Option Explicit
Sub test()
    Dim lc&, c&, ar, i&, j&, x&

第一是谢谢！
     第二是感谢！
         第三是感谢加谢谢！

xiangbaoan

心云德乐 发表于 2019-11-22 00:20
是的，您好厉害！请高手帮忙看看贴子：求助，求老司机带路，求VBA代码实现Sheet1曲线数据汇总到Sheet2， ...

Option Explicit
Sub test()
    Dim lc&, c&, ar, i&, j&, k&, x&
    With Sheet1
        lc = .Cells(4, .Columns.Count).End(xlToLeft).Column
        ar = .[a4].CurrentRegion.Resize(, lc)
    End With
    ReDim br(1 To UBound(ar), 1 To -Int(-lc / 8))
    For c = 1 To lc Step 8
        k = 0
        x = x + 1
        For i = UBound(ar) To 1 Step -1
            k = k + 1
            j = c + 7 - Abs(((k - 1) Mod 12) - 7 + 1) - 1
            br(i, x) = ar(i, j)
        Next
    Next
    Sheet2.[a4].Resize(k, x) = br
End Sub

xiangbaoan

Sub test2() '来个稍复杂一点的。
    Dim ar, h&, w&, c&, i&, j&, k&, n&, x&
    With Sheet1
        h = .Cells.Find("*", , , , 1, 2).Row - 3
        w = .Cells.Find("*", , , , 1, 2).Column
        ar = .[a4].Resize(h, w)
    End With
    n = 7
    ReDim br(1 To h, 1 To -Int(-w / 8))
    For j = 1 To w Step 8
        c = c + 1
        For i = h To 1 Step -1
            x = n - Abs(((h - i) Mod (n * 2 - 2)) - n + 1)
            br(i, c) = ar(i, j - 1 + x)
        Next
    Next
    With Sheet2
        .Cells.ClearContents
        .[a4].Resize(h, c) = br
    End With
End Sub