【021】整理力学拉伸实验数据（复制、黏贴、计算）_#VBA

1. 需求

2. 实现流程

2.1 流程图

流程如上，因测试得到多个数据表格，先将表格数据合并，并以文件名作为每个数据的代号。然后更换坐标轴，通过对文件名数据的处理，得到最终曲线的数据。

2.2 运行方法

First: 打开下载的Excel文件，点击 视图—>宏—>查看宏

Second: 弹出如下界面后，点击 编辑，弹出代码对话框，在红色框内输入对应的数据文件夹


**Third:**在宏的界面，依次点击 “整理所有数据放在总表内” / “切换坐标轴” / “提取文件名及初始拉伸距离” / “对数据进行计算”，然后点击执行即可

2.3 存在问题

对数据进行计算，，，这一栏数据处理时，遇到大量数据时容易卡住，进度很慢，容易卡死

3. 完整代码

Sub 整理所有数据放在总表内()

    Application.DisplayAlerts = False
    ' 关闭信息提示弹窗
    
    Dim MyFile As String
    Dim erow As Long
    Dim Filepath As String
    erow = 1
    Filepath = "********\****\" '设置需要遍历的文件夹路径，文件路径最后一定要有'\'
    MyFile = Dir(Filepath)
    
    Do While Len(MyFile) > 0
        If MyFile = "Master.xlsm" Then GoTo NextFile '跳过当前工作表
        Workbooks.Open (Filepath & MyFile)
        
        '提取数据
        LastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
        Range("B2:C" & LastRow).Copy
        
        '粘贴到总表
        
        Sheet1.Cells(1, 2 * erow - 1) = MyFile '在第一列写入文件名
        Sheet1.Cells(2, 2 * erow - 1).PasteSpecial
        
        Workbooks(MyFile).Close
        SaveChanges = False
        erow = erow + 1
NextFile:
        MyFile = Dir()
    Loop

End Sub

Sub 切换坐标轴()

    For i = 1 To (Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column + 1) / 2
        Sheets("Sheet1").Select
        Range(Columns(2 * i - 1), Columns(2 * i - 1)).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Cells(1, 2 * i).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
        Range(Columns(2 * i), Columns(2 * i)).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Cells(1, 2 * i - 1).Select
        ActiveSheet.Paste
    Next
End Sub
    
Sub 提取文件名及初始拉伸距离()

    ' 提取文件名至sheet3第一列中
    Sheets("Sheet2").Select
    Range("1:1").Select
    Selection.Copy
    Sheets("Sheet3").Range("A1").PasteSpecial Transpose:=True
    Sheets("Sheet3").Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    Sheets("Sheet3").Select
    t = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
    For j = 1 To t
        dataArray = Split(Cells(j, 1), "-")
        Value = dataArray(UBound(dataArray) - 1)
        ' 去除"mm"
        Cells(j, 2) = Replace(Value, "mm", "")
    Next
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Cells(1, 1).Value = "文件名"
    Cells(1, 2).Value = "初始距离(mm)"
    Cells(1, 3).Value = "截面积(mm^2)"
    
End Sub

Sub 对数据进行计算()

    Dim i As Long, j As Long, k As Long
    
    '根据Sheet3矩阵进行运算
    t = (Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column + 1)
    
    For i = 1 To t / 2
      For j = 4 To Sheets("Sheet2").Cells(Rows.Count, i * 2).End(xlUp).Row
        Sheets("Sheet4").Cells(j, 2 * i - 1) = Sheets("Sheet2").Cells(j, 2 * i - 1) / Sheets("Sheet3").Cells(i + 1, 2)
        Sheets("Sheet4").Cells(j, 2 * i) = Sheets("Sheet2").Cells(j, 2 * i - 1) / Sheets("Sheet3").Cells(i + 1, 3)
      Next j
    Next i
    
    For i = 1 To t / 2
      Sheets("Sheet4").Cells(1, 2 * i) = Sheets("Sheet2").Cells(1, 2 * i).Value + 1
      Sheets("Sheet4").Cells(2, 2 * i) = "strain"
      Sheets("Sheet4").Cells(2, 2 * i + 1) = "stress"
      Sheets("Sheet4").Cells(3, 2 * i + 1) = "MPa"
    Next
    
End Sub