VBA工位平衡分析

excel菜鸟一只，分享一个最近写的vba
先分享一款视频分析软件（ExStrategy FIE v1.0 ），导出的数据格式如下，

Paste_Image.png

该软件导出的文件放置在同一个文件夹下，新建excel文件开启宏，然后粘贴以下代码，模块一

Option Explicit

'汇总数据
Sub Gather()
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim wk As Workbook, Path$, File$, sh As Worksheet, ss$, es As Range, n%
   
    Path = ThisWorkbook.Path
    
    Dim ws As Workbook
    
    Set ws = ThisWorkbook
    Set sh = ws.Worksheets(1)
    sh.Cells.Clear
    
    File = Dir(Path & "\*.xlsx")
    
    Dim R%, cl%, Temp As Range, i%, Item As Range
    '起始位置的行数
    R = 4
    '起始位置的列数
    cl = 2
    
    Do While File <> ""
          If File <> ws.Name Then
            Set wk = Workbooks.Open(Path & "\" & File)
            Set es = wk.Sheets(1).UsedRange.Cells(3, 2).CurrentRegion
            '设置保留一位小数
            es.NumberFormatLocal = "0.0"
            Set Temp = es.Columns(1).Resize(, 1)
            es.Columns(2).Resize(, 1).Copy sh.Cells(R, cl + n)
            With sh
                For i = 1 To Temp.Rows.count
                    With .Cells(R + i - 1, cl + n)
                    If .Comment Is Nothing Then
                       .AddComment Text:=Temp.Cells(i).Value
'                       .Comment.Visible = True
                    End If
                End With
                Next
            .Cells(R - 1, cl + n).Value = Split(wk.Name, ".")(0)
            End With
            n = n + 1
            wk.Close
            File = Dir
          End If
    Loop
    
    '保存汇总表
    ws.Save
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "汇总成功！"
    
    
End Sub

在excel中运行该文件，汇总完成后，出现汇总成功的命令。
模块二

Option Explicit

'绘制工位平衡图形
Sub ChartAdd()
      Dim myRange As Range
      Dim myChart As ChartObject
      With Sheet1
     .ChartObjects.Delete
         
        '显示图形
          Set myRange = .UsedRange.Offset(2)
          Set myChart = .ChartObjects.Add(50, 200, 400, 250)
          With myChart.Chart
              .ChartType = xlColumnStacked
               .SetSourceData Source:=myRange, PlotBy:=xlRows
              .ApplyDataLabels ShowValue:=True
              .HasLegend = False
              .HasTitle = True
              .ChartTitle.Text = "平衡分析"
              
              With .ChartTitle.Font
                  .Size = 20
                  .ColorIndex = 3
                  .Name = "华文新魏"
              End With
              With .ChartArea.Interior
                  .ColorIndex = 8
                  .PatternColorIndex = 1
                  .Pattern = xlSolid
              End With
              With .PlotArea.Interior
                  .ColorIndex = 35
                  .PatternColorIndex = 1
                  .Pattern = xlSolid
              End With

          End With
          '监控编辑更新
          Call jiSuan
         
      End With
      Set myRange = Nothing
      Set myChart = Nothing
End Sub

Sub jiSuan()
'计算平衡率
          Dim i%, num%, arr(), rate As Double
          Dim myRange
          With WorksheetFunction
            Set myRange = Sheet1.UsedRange
            num = myRange.Columns.count
            ReDim arr(num)
              For i = 0 To num - 1
                  arr(i) = .Sum(myRange.Columns(i + 1).Offset(3))
              Next i
              rate = .Sum(arr) / (.Max(arr) * num)
          End With
          '添加显示标签
            Dim myShape As Shape
            '查找是否具有label标签，如果有则需要删除该标签
            For Each myShape In Sheet1.Shapes
                If InStr(myShape.Name, "Label") <> Empty Then
                    myShape.Delete
                    Exit For
                End If
            Next
            Set myShape = Sheet1.Shapes.AddFormControl(xlLabel, 55, 220, 80, 15)
            With myShape
                .TextFrame.Characters.Text = "平衡率：" & Format(rate, "0.00%")
            End With
        
End Sub

模块二是将汇总出来的动作内容，用图表表示出来。
一下为模块三的代码，模块是生成图表的文件，但是需要excel模板配合，截图一张。

Paste_Image.png

'生成新的工时表
Sub makeNew()
        '计算平衡率
        Dim R As Range, i%, row%, rng As Range, rHead As Range
            With Sheet1
                .Activate
                '选择工序名称
                Set rHead = .UsedRange.Rows(3).Resize(1)
                '选择每个工序的时间
                Set R = .UsedRange
                R.Select
                    With Sheet4
                         For i = 1 To R.Columns.count
                            row = 7 + i
                            If i > 1 Then
                                .Rows(row).Insert
                                .Rows(row).RowHeight = Sheet4.Rows(8).RowHeight
                                .Range("d" & row & ":e" & row).Merge
                            End If
                            Set rng = .Range("C" & row)
                            '设置每一个工位所有工序的和，宽放为自己设置
                            '  时间和
                                rng.Offset(0, 4).Value = WorksheetFunction.Sum(R.Columns(i))
                                '序号
                                rng.Value = i
                                '工位名称
                                rng.Offset(0, 1).Value = rHead.Cells(i)
                                '人力
                                rng.Offset(0, 3).Value = 1
                                rng.Offset(0, 9).FormulaR1C1 = "=TRIMMEAN(RC[-5]:RC[-1],0.3)"
                                rng.Offset(0, 10).Formula = "=(M5+1)*L" & row
                                rng.Offset(0, 11).Formula = "=M" & row & "/F" & row
                                
                        Next
                    End With
            End With
            '设置工时表的格式
            With Sheet4
                .Activate
                .Range("F5").Value = "日期：" & Format(Date, "yyyy-mm-dd")
                Dim rRow As Long
                Dim LRow As Long
                rRow = .UsedRange.row
                LRow = rRow + .UsedRange.Rows.count - 5
                For i = LRow To rRow Step -1
                    If Application.WorksheetFunction.CountA(Rows(i)) = 0 Or i > row Then
                        Rows(i).Delete
                    End If
                 Next
            End With
    
End Sub

最后在worksheet1中需要设置一个事件监听，这样在调整工序动作的时候，就可以及时更新标签，代码如下

···
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If (.Column < 4 Or .Column > 20) And (.row < 2 Or .row > 30) Then

    Else
    Call jiSuan
    
    End If
End With

End Sub

···
这样基本可以实现工位平衡的动作调整。
截图如下

Paste_Image.png Paste_Image.png