宏录制

1、在vba视图中写以下子程序及函数

Sub 数据整理()


    Application.DisplayAlerts = False
    
    If ExistSheet("数据表") = True Then
        Sheets("数据表").Delete
    End If
    
    Dim sh As Object
    Set sh = Sheets.Add
    
    sh.Name = "数据表"
    
    Dim rowcnt As Integer
    Dim colcnt As Integer
    
    rowcnt = GetRowCnt
    colcnt = GetColCnt
    
    Sheets("原始表").Select
    Sheets("原始表").Range(Cells(2, 1), Cells(rowcnt, 6)).Select
    Selection.Copy
    
    sh.Select
    Dim i As Integer
    Dim row As Integer
    For i = 1 To GetColCnt - 6
        row = (i - 1) * GetRowCnt + 1
        sh.Cells(row, 1).Select
        ActiveSheet.Paste
    Next
    
    Dim col As Integer
    For i = 1 To GetColCnt - 6
        col = colcnt - 6 + i
        Sheets("原始表").Select
        Sheets("原始表").Range(Cells(2, col), Cells(rowcnt, col)).Select
        Selection.Copy
        sh.Select
        row = (i - 1) * rowcnt + 1
        sh.Cells(row, 7).Select
        ActiveSheet.Paste
        
        Sheets("原始表").Select
        Sheets("原始表").Cells(2, col).Select
        Application.CutCopyMode = False
        Selection.Copy
        sh.Select


        sh.Range(Cells(row + 1, 8), Cells(row + rowcnt - 2, 8)).Select
        ActiveSheet.Paste
        
        sh.Cells(row, 7).Value = "测量值"
        sh.Cells(row, 8).Value = "测量编号"
    Next
    If MsgBox("是否合并为连续数据？", vbYesNo) = vbYes Then
        Call DeleteRow(sh, rowcnt, colcnt)
    End If
    
    If MsgBox("是否退出？", vbYesNo) = vbYes Then
        Dim w As Workbook
        For Each w In Application.Workbooks
            w.Save
        Next w
        Application.Quit
    End If
End Sub


Function ExistSheet(sheetname As String) As Boolean
    Dim b As Boolean
    b = False
    For Each s In Sheets
        If s.Name = sheetname Then
            b = True
            Exit For
        End If
    Next
    ExistSheet = b
End Function


Function GetRowCnt() As Integer
    Dim i As Integer
    Dim sh As Object
    Set sh = Sheets("原始表")
    
    i = 2
    Do While True
        If sh.Cells(i, 1).Value = "" Then Exit Do
        i = i + 1
    Loop
    GetRowCnt = i - 1
End Function


Function GetColCnt() As Integer
    Dim i As Integer
    Dim sh As Object
    Set sh = Sheets("原始表")
    i = 6
    Do While True
        If sh.Cells(2, i).Value = "" Then Exit Do
        i = i + 1
    Loop
    GetColCnt = i - 1
End Function


Sub DeleteRow(sh As Object, rowcnt As Integer, colcnt As Integer)
    Dim i As Integer
    Dim row As Integer
    Dim str As String
    sh.Select
    For i = 1 To colcnt - 6
        row = rowcnt * i
        str = str & row & ":" & row + 1 & ","
    Next
    str = Left(str, Len(str) - 1)
    sh.Range(str).Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    
    sh.Cells(1, 1).Select
    i = 1
    Do While True
        i = i + 1
        If sh.Cells(i, 1).Value = "" Then Exit Do
        sh.Cells(i, 1).Value = i - 1
    Loop
End Sub

2、运行“数据整理”

3、示例文件：

点击下载此附件