Sub ExtractMaxValueOptimized()
Dim startTime As Double: startTime = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
’ 定义变量 Dim sourceWb As Workbook, sourceWs As Worksheet, targetWs As Worksheet Dim sourcePath As String: sourcePath = “D:\大连东风日产实习\原始数据表1\4.xlsx” ’ 修改路径 Dim yellowCols As Collection, partDict As Object Dim glCol As Long, flowCol As Long, partCol As Long Dim targetPartCol As Long, targetValueCol As Long Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long ’ 设置目标表 Set targetWs = ThisWorkbook.Sheets(“部品需求表”) ’ 打开源工作簿 Set sourceWb = Workbooks.Open(sourcePath, ReadOnly:=True) Set sourceWs = sourceWb.Sheets(“SOP合并清单”) ’ 获取源表尺寸 lastRow = sourceWs.Cells(sourceWs.Rows.Count, “A”).End(xlUp).Row lastCol = sourceWs.Cells(8, sourceWs.Columns.Count).End(xlToLeft).Column ’ 标题在第8行 ’ 步骤1: 查找关键列位置 glCol = FindColumnByHeader(sourceWs, “GL”, 8) flowCol = FindColumnByHeader(sourceWs, “流用情况”, 8) partCol = FindColumnByHeader(sourceWs, “部番”, 8) ’ 验证关键列 If glCol = 0 Or flowCol = 0 Or partCol = 0 Then MsgBox "关键列未找到: " & IIf(glCol = 0, "GL ", “”) & IIf(flowCol = 0, “流用情况 “, “”) & IIf(partCol = 0, “部番”, “”), vbCritical GoTo Cleanup End If ’ 步骤2: 识别黄色列（第5行） Set yellowCols = New Collection For j = 1 To lastCol If sourceWs.Cells(5, j).Interior.Color = RGB(255, 255, 0) Then yellowCols.Add j End If Next j If yellowCols.Count = 0 Then MsgBox “未找到黄色标记列”, vbExclamation GoTo Cleanup End If ’ 步骤3: 初始化字典存储零件最大值 Set partDict = CreateObject(“Scripting.Dictionary”) ’ 步骤4: 高效数据处理（从第9行开始） Dim rowData As Variant, cellValue As Variant Dim partNumber As String, flowStatus As String Dim maxValue As Double ’ 使用数组一次性读取所有数据（大幅提升性能） Dim dataRange As Range Set dataRange = sourceWs.Range(sourceWs.Cells(9, 1), sourceWs.Cells(lastRow, lastCol)) Dim dataArray As Variant dataArray = dataRange.value ’ 处理每一行数据 For i = 1 To UBound(dataArray, 1) ’ 筛选条件1: GL列必须为"焊装车间” If UCase(Trim(dataArray(i, glCol))) = “焊装车间” Then ’ 筛选条件2: 流用情况列必须含"A” flowStatus = dataArray(i, flowCol) If InStr(1, flowStatus, “A”, vbTextCompare) > 0 Then ’ 获取零件编码 partNumber = dataArray(i, partCol) If partNumber <> “” Then ’ 初始化最大值 maxValue = -1.79769313486231E+308 ’ 检查所有黄色列的值 For Each j In yellowCols cellValue = dataArray(i, j) If IsNumeric(cellValue) Then If cellValue > maxValue Then maxValue = cellValue End If Next j ’ 更新字典值（只保留最大值） If maxValue > -1.79769313486231E+308 Then If partDict.Exists(partNumber) Then If maxValue > partDict(partNumber) Then partDict(partNumber) = maxValue Else partDict.Add partNumber, maxValue End If End If End If End If End If Next i ’ 步骤5: 将结果写入目标表 If partDict.Count > 0 Then ’ 获取目标表列位置 targetPartCol = FindColumnByHeader(targetWs, “零件编码”, 1) targetValueCol = FindColumnByHeader(targetWs, “A车用量”, 1) If targetPartCol = 0 Or targetValueCol = 0 Then MsgBox “目标表关键列未找到”, vbCritical GoTo Cleanup End If Dim targetLastRow As Long targetLastRow = targetWs.Cells(targetWs.Rows.Count, targetPartCol).End(xlUp).Row ’ 创建零件编码数组用于快速查找 Dim targetParts() As String, targetValues() As Double ReDim targetParts(1 To targetLastRow) ReDim targetValues(1 To targetLastRow) For i = 2 To targetLastRow targetParts(i) = targetWs.Cells(i, targetPartCol).value Next i ’ 批量更新值 For i = 2 To targetLastRow If partDict.Exists(targetParts(i)) Then targetValues(i) = partDict(targetParts(i)) End If Next i ’ 一次性写入所有值 targetWs.Range(targetWs.Cells(2, targetValueCol), targetWs.Cells(targetLastRow, targetValueCol)).value = _ Application.Transpose(targetValues) MsgBox “处理完成! 共处理 " & partDict.Count & " 个零件” & vbCrLf & _ “耗时: " & Format(Timer - startTime, “0.00”) & " 秒”, vbInformation Else MsgBox “未找到符合条件的数值”, vbExclamation End If
Cleanup:
’ 清理资源
sourceWb.Close SaveChanges:=False
Set sourceWs = Nothing
Set sourceWb = Nothing
Set targetWs = Nothing
’ 恢复应用设置 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True
End Sub
’ 高效列查找函数
Function FindColumnByHeader(ws As Worksheet, headerText As String, headerRow As Long) As Long
Dim headerRange As Range
Set headerRange = ws.Rows(headerRow)
Dim cell As Range For Each cell In headerRange If Not IsEmpty(cell) Then If InStr(1, cell.value, headerText, vbTextCompare) > 0 Then FindColumnByHeader = cell.Column Exit Function End If End If Next cell FindColumnByHeader = 0
End Function
代码运行结果为”FOR EACH控件变量必须为变体或对象“，请分析原因并修改然后生成一份完整的代码
本文介绍了一种基于字符串排列的计数算法，该算法能够针对输入的字符串计算满足特定条件的排列数量。通过动态规划的方法，算法实现了高效计算，特别适用于处理包含'I'（增加）和'D'（减少）指令的字符串。
扫一扫
9202
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
