Option Explicit Public MyPath As String Public InputPath As String Public OutputPath As String Public shList As Worksheet Public shConstruct As Worksheet Public shGather As Worksheet Public shTotal As Worksheet Type Zhipin Name As String Num As Long End Type Type Bupin Name As String Proc As String Num As Long Description As String End Type Sub 制品汇总输出() Const LIST_START_ROW = 2 Dim wbNew As Workbook Dim shNew As Worksheet Dim wbTemp As Workbook Dim shTemp As Worksheet Dim rgTemp As Range Dim strTemp As String Dim Openfile As String Dim strDanhao As String Dim strM As String Dim Model() As Zhipin Dim ProcList() As Bupin Dim i As Long, ii As Long, iii As Long, iiii As Long, j As Long, k As Long, l As Long, x As Long Dim lgRangeSide As Long Dim Links As Variant Application.ScreenUpdating = False Application.DisplayAlerts = False On Error GoTo Err 'InputPath = "C:/输入/" 'OutputPath = "C:/Documents and Settings/SMC8236/桌面/输出/" If InputPath = "" Or OutputPath = "" Then MsgBox "请在汇总前,设置输入输出路径!“" GoTo Err End If Set shList = Worksheets("清单") Set shConstruct = Worksheets("构成表") Set shGather = Worksheets("汇总表") Set shTotal = Worksheets("合计列") With shList ReDim Model(.UsedRange.Rows.Count - 1) j = 0 l = 0 For i = LIST_START_ROW To UBound(Model) + 1 Model(j).Name = .Cells(i, 1).Value Model(j).Num = .Cells(i, 2).Value l = l + Model(j).Num j = j + 1 Next End With With shConstruct For i = 0 To UBound(Model) - 1 ReDim ProcList(Model(i).Num) k = 0 Set rgTemp = .Columns("A:A").Find(What:=Model(i).Name, Lookat:=xlPart) If rgTemp <> "" Then For j = rgTemp.Row To rgTemp.Row + Model(i).Num - 1 ProcList(k).Name = .Cells(j, 2).Value ProcList(k).Description = .Cells(j, 4).Value ProcList(k).Proc = .Cells(j, 5).Value ProcList(k).Num = .Cells(j, 6).Value k = k + 1 Next x = 3 Set wbNew = Workbooks.Add Set shNew = wbNew.ActiveSheet For ii = 0 To UBound(ProcList) - 1 k = 0 Openfile = InputPath & ProcList(ii).Proc & ProcList(ii).Name & ".xls" Set wbTemp = Workbooks.Open(Openfile) Set shTemp = wbTemp.Worksheets("链接") Set rgTemp = shTemp.Columns("A:B").Find(What:="部品型号", Lookat:=xlPart) If rgTemp Is Nothing Then Set rgTemp = shTemp.Columns("A:B").Find(What:="制品型号", Lookat:=xlPart) End If If rgTemp Is Nothing Then GoTo Err Else l = rgTemp.Row End If For j = 3 To 255 If shTemp.Cells(l + 2, j).Value <> "" Then k = k + 1 Else Exit For End If Next shTemp.Range("C4").AddComment (Str(ProcList(ii).Num)) shTemp.Range("C4").Comment.Visible = False shTemp.Cells.Copy shNew.Cells.PasteSpecial xlPasteAll Links = wbNew.LinkSources(xlExcelLinks) On Error Resume Next If Not IsEmpty(Links) Then For iii = 1 To UBound(Links) wbNew.BreakLink Name:=Links(iii), Type:=xlLinkTypeExcelLinks Next End If On Error GoTo 0 If InStr(1, shTemp.Parent.Name, "组装") <> 0 Then strTemp = "A:" & Split(shNew.Cells(l + 2, 3 + k - 1).Address, "$")(1) shNew.Range(strTemp).Copy shGather.Range(Split(Cells(1, x + 1).Address, "$")(1) & ":" & Split(Cells(1, x + 1).Address, "$")(1)).PasteSpecial xlPasteAll shGather.Range(Split(Cells(1, x).Address, "$")(1) & ":" & Split(Cells(1, x).Address, "$")(1)).ColumnWidth = 1 shGather.Range(Split(Cells(1, x).Address, "$")(1) & ":" & Split(Cells(1, x).Address, "$")(1)).Value = 0.0000000001 shGather.Range(Split(Cells(1, x).Address, "$")(1) & ":" & Split(Cells(1, x).Address, "$")(1)).Font.Color = shGather.Range(Split(Cells(1, x).Address, "$")(1) & ":" & Split(Cells(1, x).Address, "$")(1)).Interior.Color '空行不被删掉,所以赋值一个0.001,字体颜色和背景色一直 Else strTemp = "C:" & Split(shNew.Cells(l + 2, 3 + k - 1).Address, "$")(1) shNew.Range(strTemp).Copy shGather.Range(Split(Cells(1, x).Address, "$")(1) & ":" & Split(Cells(1, x).Address, "$")(1)).PasteSpecial xlPasteAll End If x = x + k Application.CutCopyMode = False wbTemp.Close False shNew.Cells.Delete Next With shGather On Error Resume Next '.Cells(1, 1).Value = Model(i).Name & " (" & Month(Now) & "月)" .Cells(1, 1).Value = Model(i).Name & " (4月)" strTemp = "" For iii = 3 To x + 2 If .Cells(4, iii).Value <> "小计" Then If IsError(.Cells(34, iii)) Then .Cells(34, iii).Value = "" Else If .Cells(34, iii).Value = 0 Then .Cells(34, iii).Value = "" End If End If End If Next For iii = 3 To x + 2 If Not IsError(.Cells(34, iii)) Then If InStr(1, .Cells(2, iii).Value, "型号") = 0 Then If Not Cells(34, iii).MergeCells Then If .Cells(34, iii).Value = "" Then strTemp = strTemp & Replace(.Cells(34, iii).Address, "$", "") & "," End If End If End If End If Next .Range(Left(strTemp, Len(strTemp) - 1)).Select .Range(Left(strTemp, Len(strTemp) - 1)).EntireColumn.Delete On Error GoTo 0 lgRangeSide = .UsedRange.Columns.Count For iii = 3 To lgRangeSide If .Cells(4, iii).Value = "小计" Then x = 0 Else x = x + 1 .Cells(4, iii).Value = x End If Next For iii = 3 To lgRangeSide If .Cells(2, iii).Value <> "" Then strM = .Cells(2, iii).Value End If For iiii = iii + 1 To lgRangeSide If .Cells(2, iiii).Value <> "" Then If .Cells(2, iiii).Value = strM Then .Range(.Cells(2, iii), .Cells(2, iiii)).Merge End If End If Next Next For iii = 3 To lgRangeSide If .Cells(4, iii).Value = "小计" Then If .Cells(4, iii).Comment.Text <> 1 Then strDanhao = .Cells(4, iii).Comment.Text For iiii = 8 To 45 If Not IsEmpty(.Cells(iiii, iii).Formula) And .Cells(iiii, iii).Value <> "" Then .Cells(iiii + 42, iii).Formula = .Cells(iiii, iii).Formula & "*" & Trim(strDanhao) End If Next End If End If Next shTotal.Range("A:B").Copy .Range(Split(Cells(1, lgRangeSide + 1).Address, "$")(1) & ":" & Split(Cells(1, lgRangeSide + 1).Address, "$")(1)).PasteSpecial xlPasteAll For iii = 6 To 45 If .Cells(iii, lgRangeSide + 2).Interior.ColorIndex <> -4142 Then .Cells(iii, lgRangeSide + 2).Formula = "=ROUND(SUM(" & "C" & Trim(Str(iii + 45)) & ":" & Split(Cells(1, lgRangeSide).Address, "$")(1) & Trim(Str(iii + 45)) & "),2)" .Cells(iii, lgRangeSide + 2).Interior.ColorIndex = -4142 End If Next End With shGather.Copy ActiveWorkbook.UpdateLinks = xlUpdateLinksNever ActiveWorkbook.Close True, OutputPath & Model(i).Name & ".xls" End If Call 清空汇总表 wbNew.Close Set shNew = Nothing Next End With '------------------------------------------ Err: MsgBox Error Set shTemp = Nothing Set wbTemp = Nothing Set shList = Nothing Set shConstruct = Nothing Set shGather = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "汇总表生成完毕" End Sub Sub 选择数据源() Call Browse_Path InputPath = MyPath End Sub Sub 选择输出目录() Call Browse_Path OutputPath = MyPath End Sub Sub 清空汇总表() Worksheets("汇总表").Select Columns("C:C").Select Range(Selection, Columns("IV:IV")).Select Selection.Delete Shift:=xlToLeft Range("C2").Select End Sub