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
