Excel工作表数据拆分及合并

之前写过用 VBA 代码如何快速进行Excel工作簿的拆分及合并, 现在又遇到的新的情况，需要对工作表中的曲线进行处理，这里做个补充。

GetCorrectionData 在手动拆分完滞回曲线后，可以对每一圈的数据进行单独处理，最后将每一圈的数据输出到表格中。然而，有时候需要将拆分后的滞回环合并成一整条滞回曲线，那就需要将每一圈的数据粘贴复制进行拼接，这会很麻烦，可以用下面的代码来解决。

建议在使用前备份原始数据！
建议在使用前备份原始数据!
建议在使用前备份原始数据!

将一张表格中的所有滞回环合并为一条滞回曲线

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub 合并滞回环为一条曲线()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim rowCount As Long
    Dim i As Integer
    Dim sourceSheetName As String
    ' 要求输入源工作表的名称
    sourceSheetName = InputBox("请输入源工作表的名称：")
    ' 设置源工作表和目标工作表
    Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
    Set targetSheet = ThisWorkbook.Sheets.Add
    ' 获取源工作表的列数
    lastCol = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
    ' 复制第1、2列的数据到目标工作表
    For i = 1 To lastCol Step 2
        ' 获取源工作表的最后一行
        lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, i).End(xlUp).Row
        ' 获取目标工作表的行数
        rowCount = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row
        sourceSheet.Range(sourceSheet.Cells(1, i), sourceSheet.Cells(lastRow, i + 1)).Copy Destination:=targetSheet.Cells(rowCount + 1, 1)
    Next i
    MsgBox "已将所有滞回环合并为一条滞回曲线！"
End Sub

具体操作步骤和效果，可以看以下演示动画，需要输入工作表的名称：

将一张工作表的中曲线拆分到单个工作表中

将上面的代码稍做修改，就可以将每条曲线拆分到单个工作表中存放，代码如下：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub 拆分滞回环到单个工作表()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim rowCount As Long
    Dim i As Integer
    Dim sourceSheetName As String
    Dim num As Integer
    num = 0
    ' 要求输入源工作表的名称
    sourceSheetName = InputBox("请输入源工作表的名称：")
    ' 设置源工作表和目标工作表
    Set sourceSheet = ThisWorkbook.Sheets(sourceSheetName)
    ' 获取源工作表的列数
    lastCol = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
    ' 复制第1、2列的数据到目标工作表
    For i = 1 To lastCol Step 2
        ' 获取源工作表的最后一行
        lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, i).End(xlUp).Row
        ' 新建目标工作表
        Set targetSheet = ThisWorkbook.Sheets.Add
        targetSheet.Name = num
        sourceSheet.Range(sourceSheet.Cells(1, i), sourceSheet.Cells(lastRow, i + 1)).Copy Destination:=targetSheet.Cells(1, 1)
        num = num + 1
    Next i
    MsgBox "拆分完成！"
End Sub


具体操作步骤和效果，可以看以下演示动画：