按日期排序多行多组设备测试数据的VBA问题求助

云上老周

2026-6-14

设备测试结果按日期排序问题及解决方案

问题描述

我有15台需测试并记录输出的设备，每3列对应一组测试结果。希望每行内的每组数据按日期排序，但在现有程序中添加该功能时，出现了整行排序、日期仍非连续、仅单独排序日期等问题，目前无法解决。

现有代码

Sub TransferData()

    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim searchValue As Long
    Dim lastRowSource As Long
    Dim i As Long
    Dim foundCell As Range
    Dim nextColumn As Long
    Dim isDuplicate As Boolean
    Dim valueJ As Double, valueP As Double, valueV As Double
    Dim valueL As Double, valueR As Double, valueX As Double
    Dim sheetNames As Variant
    Dim sheetName As Variant
    
    ' 设置目标工作表（Amp dB Tracker）
    Set wsDest = ThisWorkbook.Sheets("Amp dB Tracker")
    
    ' 源工作表名称列表
    sheetNames = Array("GCS 003", "GCS 001", "GCS 002", "GCS 004", "GCS 005")
    
    ' 遍历每个源工作表
    For Each sheetName In sheetNames
        ' 设置当前源工作表
        Set wsSource = ThisWorkbook.Sheets(sheetName)
        
        ' 找到源工作表的最后一行
        lastRowSource = wsSource.Cells(wsSource.Rows.Count, "I").End(xlUp).Row
        
        ' 遍历源工作表的每一行（从第11行开始，假设第1行是表头）
        For i = 11 To lastRowSource
            
            ' 检查I列的设备编号（1到15）
            searchValue = wsSource.Cells(i, "I").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' 在目标工作表C列找到对应设备编号
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' 确定该行下一个可用的列（从D列开始，列号4）
                    nextColumn = 4
                    
                    ' 循环找到下一个可用的3列组（D,E/F...）
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3
                    Loop
                    
                    ' 检查该数据是否已存在于下一个可用的3列组中
                    isDuplicate = False
                    For j = 4 To nextColumn + 2
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "J").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "L").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' 如果不是重复数据，复制数据
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' 日期写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "J").Value ' J列数值写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "L").Value ' L列数值写入对应列
                        
                        ' 检查J列数值是否在20-24之间，超出则高亮红色
                        valueJ = wsSource.Cells(i, "J").Value
                        If valueJ < 20 Or valueJ > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0)
                        End If
                        
                        ' 检查L列数值是否在36.53-38.13之间，超出则高亮红色
                        valueL = wsSource.Cells(i, "L").Value
                        If valueL < 36.53 Or valueL > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0)
                        End If
                    End If
                End If
            End If
            
            ' 检查O列的设备编号（1到15）
            searchValue = wsSource.Cells(i, "O").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' 在目标工作表C列找到对应设备编号
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' 确定该行下一个可用的列（从D列开始，列号4）
                    nextColumn = 4
                    
                    ' 循环找到下一个可用的3列组（D,E/F...）
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3
                    Loop
                    
                    ' 检查该数据是否已存在于下一个可用的3列组中
                    isDuplicate = False
                    For j = 4 To nextColumn + 2
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "P").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "R").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' 如果不是重复数据，复制数据
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' 日期写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "P").Value ' P列数值写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "R").Value ' R列数值写入对应列
                        
                        ' 检查P列数值是否在20-24之间，超出则高亮红色
                        valueP = wsSource.Cells(i, "P").Value
                        If valueP < 20 Or valueP > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0)
                        End If
                        
                        ' 检查R列数值是否在36.53-38.13之间，超出则高亮红色
                        valueR = wsSource.Cells(i, "R").Value
                        If valueR < 36.53 Or valueR > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0)
                        End If
                    End If
                End If
            End If
            
            ' 检查U列的设备编号（1到15）
            searchValue = wsSource.Cells(i, "U").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' 在目标工作表C列找到对应设备编号
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' 确定该行下一个可用的列（从D列开始，列号4）
                    nextColumn = 4
                    
                    ' 循环找到下一个可用的3列组（D,E/F...）
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3
                    Loop
                    
                    ' 检查该数据是否已存在于下一个可用的3列组中
                    isDuplicate = False
                    For j = 4 To nextColumn + 2
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "V").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "X").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' 如果不是重复数据，复制数据
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' 日期写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "V").Value ' V列数值写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "X").Value ' X列数值写入对应列
                        
                        ' 检查V列数值是否在20-24之间，超出则高亮红色
                        valueV = wsSource.Cells(i, "V").Value
                        If valueV < 20 Or valueV > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0)
                        End If
                        
                        ' 检查X列数值是否在36.53-38.13之间，超出则高亮红色
                        valueX = wsSource.Cells(i, "X").Value
                        If valueX < 36.53 Or valueX > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0)
                        End If
                    End If
                End If
            End If
            
        Next i
    Next sheetName

End Sub

解决方案

要实现每行内3列组按日期排序，需在数据转移完成后，对每行的测试组进行排序。新增一个排序子过程，并在原TransferData末尾调用该过程，具体修改如下：

修改后的完整代码

Sub TransferData()

    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim searchValue As Long
    Dim lastRowSource As Long
    Dim i As Long
    Dim foundCell As Range
    Dim nextColumn As Long
    Dim isDuplicate As Boolean
    Dim valueJ As Double, valueP As Double, valueV As Double
    Dim valueL As Double, valueR As Double, valueX As Double
    Dim sheetNames As Variant
    Dim sheetName As Variant
    
    ' 设置目标工作表（Amp dB Tracker）
    Set wsDest = ThisWorkbook.Sheets("Amp dB Tracker")
    
    ' 源工作表名称列表
    sheetNames = Array("GCS 003", "GCS 001", "GCS 002", "GCS 004", "GCS 005")
    
    ' 遍历每个源工作表
    For Each sheetName In sheetNames
        ' 设置当前源工作表
        Set wsSource = ThisWorkbook.Sheets(sheetName)
        
        ' 找到源工作表的最后一行
        lastRowSource = wsSource.Cells(wsSource.Rows.Count, "I").End(xlUp).Row
        
        ' 遍历源工作表的每一行（从第11行开始，假设第1行是表头）
        For i = 11 To lastRowSource
            
            ' 检查I列的设备编号（1到15）
            searchValue = wsSource.Cells(i, "I").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' 在目标工作表C列找到对应设备编号
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' 确定该行下一个可用的列（从D列开始，列号4）
                    nextColumn = 4
                    
                    ' 循环找到下一个可用的3列组（D,E/F...）
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3
                    Loop
                    
                    ' 检查该数据是否已存在于下一个可用的3列组中
                    isDuplicate = False
                    For j = 4 To nextColumn + 2
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "J").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "L").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' 如果不是重复数据，复制数据
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' 日期写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "J").Value ' J列数值写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "L").Value ' L列数值写入对应列
                        
                        ' 检查J列数值是否在20-24之间，超出则高亮红色
                        valueJ = wsSource.Cells(i, "J").Value
                        If valueJ < 20 Or valueJ > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0)
                        End If
                        
                        ' 检查L列数值是否在36.53-38.13之间，超出则高亮红色
                        valueL = wsSource.Cells(i, "L").Value
                        If valueL < 36.53 Or valueL > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0)
                        End If
                    End If
                End If
            End If
            
            ' 检查O列的设备编号（1到15）
            searchValue = wsSource.Cells(i, "O").Value
            If searchValue >= 1 And searchValue <= 15 Then
                ' 在目标工作表C列找到对应设备编号
                Set foundCell = wsDest.Columns("C").Find(searchValue, LookIn:=xlValues)
                If Not foundCell Is Nothing Then
                    ' 确定该行下一个可用的列（从D列开始，列号4）
                    nextColumn = 4
                    
                    ' 循环找到下一个可用的3列组（D,E/F...）
                    Do While Not IsEmpty(wsDest.Cells(foundCell.Row, nextColumn))
                        nextColumn = nextColumn + 3
                    Loop
                    
                    ' 检查该数据是否已存在于下一个可用的3列组中
                    isDuplicate = False
                    For j = 4 To nextColumn + 2
                        If wsDest.Cells(foundCell.Row, j).Value = wsSource.Cells(i, "A").Value Or _
                           wsDest.Cells(foundCell.Row, j + 1).Value = wsSource.Cells(i, "P").Value Or _
                           wsDest.Cells(foundCell.Row, j + 2).Value = wsSource.Cells(i, "R").Value Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    ' 如果不是重复数据，复制数据
                    If Not isDuplicate Then
                        wsDest.Cells(foundCell.Row, nextColumn).Value = wsSource.Cells(i, "A").Value ' 日期写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 1).Value = wsSource.Cells(i, "P").Value ' P列数值写入对应列
                        wsDest.Cells(foundCell.Row, nextColumn + 2).Value = wsSource.Cells(i, "R").Value ' R列数值写入对应列
                        
                        ' 检查P列数值是否在20-24之间，超出则高亮红色
                        valueP = wsSource.Cells(i, "P").Value
                        If valueP < 20 Or valueP > 24 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 1).Interior.Color = RGB(255, 0, 0)
                        End If
                        
                        ' 检查R列数值是否在36.53-38.13之间，超出则高亮红色
                        valueR = wsSource.Cells(i, "R").Value
                        If valueR < 36.53 Or valueR > 38.13 Then
                            wsDest.Cells(foundCell.Row, nextColumn + 2).Interior.Color = RGB(255, 0, 0)
                        End If
                    End If
                End If
            End If
            
            ' 检查U列的设备编号（1到15）
            searchValue = ws

按日期排序多行多组设备测试数据的VBA问题求助

问题描述 #

相关样式说明 #

现有代码 #

解决方案 #

修改后的完整代码 #

问题描述

相关样式说明

现有代码

解决方案

修改后的完整代码