求助:求老司机带路,求VBA代码实现Sheet1曲线数据汇总到Sheet2,谢谢!
批量曲线提取.rar
(143.92 KB)
Sub getOrder() '按一定规律取值到数组,并输出到表2 'Code by:厨师王德榜 '2019-11-27 Dim iLR As Integer '-1/+1 向左还是向右 Dim irow As Integer, icolN As Integer Dim icolStart As Integer, icolEnd As Integer Dim arr1() As Integer icolN = 1 icolEnd = 1 iLR = -1 ReDim arr1(41 - 4) Worksheets("Sheet1").Activate Application.ScreenUpdating = False Do Until Cells(4, (icolN - 1) * 8 + 1).Text = "" For irow = 4 To 41 If irow = 4 Then iLR = -1 icolStart = (icolN - 1) * 8 + 2 Else If (icolStart + 1) Mod 8 = 0 Or icolStart Mod 8 = 1 Then iLR = iLR * -1 End If End If If icolStart = 0 Then icolStart = 1 arr1(irow - 4) = Cells(irow, icolStart).Value Cells(irow, icolStart).Select With Selection.Font .Color = -16777024 .TintAndShade = 0 .Bold = True End With icolStart = icolStart + iLR icolEnd = IIf(icolStart > icolEnd, icolStart, icolEnd) Next irow '输出数组(到Sheet2): Worksheets("Sheet2").Activate Cells(4, icolN).Resize(38, 1) = Application.Transpose(arr1) ReDim arr1(41 - 4) '输出后,清空数组,方便给下一轮使用. Worksheets("Sheet1").Activate icolN = icolN + 1 Loop Application.ScreenUpdating = True MsgBox "计算完毕。最末列探测到第" & icolEnd & "列." End Sub