Excel VBA实现文本文件自动导入与测试数据配对绘图的技术问询

核心功能说明 #

• 完全兼容原有txt文件夹批量导入、空格分列、单文件单工作表的逻辑，不会改动原有已跑通的导入流程
• 导入完成后自动按照文件名规则配对：识别组名-1.txt、组名-2.txt格式的文件，将同组的两个文件数据合并绘制为独立XY散点图
• 所有生成的对比图统一存放在新建的「测试结果图表」工作表中，自动纵向排列无重叠，不会干扰原始数据工作表
• 自动校验配对完整性，缺失1/2序号的组不会生成空图表

完整代码 #

Sub ImportTextToExcelWithPlot()
'UpdatebyExtendoffice20180911
Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Dim xIntRow As Long
Dim xFNum, xFArr As Long
Dim xStrValue As String
Dim xRg As Range
Dim xArr

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
    xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Then
    MsgBox "No files found", vbInformation
    Exit Sub
End If
Do While xFile <> ""
    xFiles.Add xFile, xFile
    xFile = Dir()
Loop
Set xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
If xFiles.Count > 0 Then
    For I = 1 To xFiles.Count
        Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
        xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
        ActiveSheet.Name = xWb.Name
        xWb.Close False
        ' 原有分列逻辑完全保留
        xIntRow = ActiveCell.CurrentRegion.Rows.Count
        For xFNum = 1 To xIntRow
            Set xRg = ActiveSheet.Range("A" & xFNum)
            xArr = Split(xRg.Text, " ")
            If UBound(xArr) > 0 Then
                For xFArr = 0 To UBound(xArr)
                    If xArr(xFArr) <> "" Then
                        xRg.Value = xArr(xFArr)
                        Set xRg = xRg.Offset(ColumnOffset:=1)
                    End If
                Next
            End If
        Next
    Next
    
    ' -------------------- 新增自动绘图逻辑开始 --------------------
    Dim chartWs As Worksheet
    Dim dict As Object
    Dim s As Worksheet
    Dim groupName As String
    Dim seqNum As Integer
    Dim splitPos As Integer
    Dim chartTop As Double
    Dim grp As Variant
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim co As ChartObject
    
    ' 创建/复用图表汇总工作表
    Set chartWs = Nothing
    For Each s In xToBook.Worksheets
        If s.Name = "测试结果图表" Then
            Set chartWs = s
            Exit For
        End If
    Next
    If chartWs Is Nothing Then
        Set chartWs = xToBook.Worksheets.Add(after:=xToBook.Sheets(xToBook.Sheets.Count))
        chartWs.Name = "测试结果图表"
    End If
    chartWs.Cells.Clear
    chartTop = 10
    
    ' 构建文件名配对字典
    Set dict = CreateObject("Scripting.Dictionary")
    For Each s In xToBook.Worksheets
        If s.Name <> chartWs.Name Then
            ' 匹配xxx-1.txt/xxx-2.txt格式的文件名
            If s.Name Like "*-#.txt" Then
                splitPos = InStrRev(s.Name, "-")
                groupName = Left(s.Name, splitPos - 1)
                seqNum = CInt(Mid(s.Name, splitPos + 1, InStr(s.Name, ".txt") - splitPos - 1))
                If Not dict.Exists(groupName) Then
                    Set dict(groupName) = CreateObject("Scripting.Dictionary")
                End If
                Set dict(groupName)(seqNum) = s
            End If
        End If
    Next
    
    ' 逐组生成对比图表
    For Each grp In dict.Keys
        ' 校验组内是否同时存在1、2序号的有效数据
        If dict(grp).Exists(1) And dict(grp).Exists(2) Then
            Set ws1 = dict(grp)(1)
            Set ws2 = dict(grp)(2)
            ' 读取两个工作表的有效数据范围
            lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
            lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
            ' 新建散点图对象
            Set co = chartWs.ChartObjects.Add(Left:=10, Width:=480, Height:=320, Top:=chartTop)
            co.Chart.ChartType = xlXYScatterLinesNoMarkers
            ' 加载第一组数据
            With co.Chart.SeriesCollection.NewSeries
                .Name = Replace(ws1.Name, ".txt", "")
                .XValues = ws1.Range("A2:A" & lastRow1)
                .Values = ws1.Range("B2:B" & lastRow1)
            End With
            ' 加载第二组数据
            With co.Chart.SeriesCollection.NewSeries
                .Name = Replace(ws2.Name, ".txt", "")
                .XValues = ws2.Range("A2:A" & lastRow2)
                .Values = ws2.Range("B2:B" & lastRow2)
            End With
            ' 图表基础样式设置
            co.Chart.HasTitle = True
            co.Chart.ChartTitle.Text = grp & " 测试结果对比"
            co.Chart.Axes(xlCategory).HasTitle = True
            co.Chart.Axes(xlCategory).AxisTitle.Text = "X轴"
            co.Chart.Axes(xlValue).HasTitle = True
            co.Chart.Axes(xlValue).AxisTitle.Text = "Y轴"
            ' 更新下一张图的位置，避免重叠
            chartTop = chartTop + 340
        End If
    Next
    ' -------------------- 新增自动绘图逻辑结束 --------------------
End If
Application.ScreenUpdating = True
End Sub

使用注意事项 #

• 数据行规则默认假设每个导入的工作表第一行为表头，数据从第二行开始存放；如果数据直接从第一行开始，可将代码中A2:A" & lastRow1、B2:B的起始行号改为1
• 图表类型默认设置为无数据标记的连线散点图，可通过修改co.Chart.ChartType的参数切换为纯散点图、带标记散点图等自定义类型
• 如果需要调整图表大小、间距，直接修改ChartObjects.Add方法中的宽、高、Top参数即可

内容的提问来源于stack exchange，提问作者Jared McNamara