分享：VBA鋼鐵企業庫存資料自動取數與分析報表程式，重點邏輯思維、資料規則等歡迎讨論！！！！！
PrivateSub CommandButton6_Click() '庫存執行按鈕
'删除庫存資料中得空行及空列
Dim LastRow As Long, 空行 As Long
Dim LastColumn As Long, 空列 As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
LastRow = ActiveSheet.UsedRange.Rows.Count
LastRow = LastRow + ActiveSheet.UsedRange.Row - 1
For 空行 = LastRow To 1 Step -1
If WorksheetFunction.CountA(Rows(空行)) = 0 Then Rows(空行).Delete
Next 空行
LastColumn = ActiveSheet.UsedRange.Columns.Count
LastColumn = LastColumn + ActiveSheet.UsedRange.Column
For 空列 = LastColumn To 1 Step -1
If WorksheetFunction.CountA(Columns(空列)) = 0 Then Columns(空列).Delete
Next 空列
'将庫存資料第一行所有空格去掉！
Rows("1:1").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'判斷有效資料的行數及列數，并把最後一行和前兩列删除！
Dim 有效行數, 有效列數
有效行數 = Sheet1.UsedRange.Rows.Count '取資料的有效行數
有效列數 = Sheet1.UsedRange.Columns.Count '取資料有效列數
Rows(有效行數).EntireRow.Delete '删除庫存臨時表最後行
'Rows(有效行數 - 1).EntireRow.Delete
Range("A:A,B:B").Select '删除A、B兩列
Selection.Delete Shift:=xlToLeft
'将物料編碼列變成文本格式
Dim 文本格式&
'文本格式 = Application.ActiveSheet.UsedRange.Rows.Count
'Rows(i).Delete
Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 2), TrailingMinusNumbers:=True
'在庫存表增加3列，用存放“物料編碼大類”、“計劃員”、“備件類别”三列資料！
Columns("B:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").Select
ActiveCell.FormulaR1C1 = "物料編碼大類"
Range("C1").Select
ActiveCell.FormulaR1C1 = "計劃員"
Range("D1").Select
ActiveCell.FormulaR1C1 = "備件類别"
Range("B1:D1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B8").Select
Columns("B:B").ColumnWidth = 6.13
Columns("C:C").ColumnWidth = 5.88
Columns("D:D").ColumnWidth = 8.13
Columns("G:G").ColumnWidth = 6.25
Columns("H:H").ColumnWidth = 5.75
Columns("D:D").ColumnWidth = 5.75
'取物料編碼大類：若物料編碼為10位數，則取該編碼的前四位數；若物料編碼13位且為開頭為B0—B6位數，則取該編碼的前兩位數；
'若物料編碼為13位數且為B999開頭，則取該編碼的前五位數；
有效行數 = Sheet1.UsedRange.Rows.Count
Dim 行數變量 As Long
'插入進度條
For 行數變量 = 2 To 有效行數 Step 1
DoEvents
ProgressBar1.Value = 行數變量 '進度條步行
ProgressBar1.Max = 有效行數 '進度條最大值設定
Label2.Caption = "正在進行物料大類碼處理，請稍後..........."
'取物料大類碼程式
If Len(Range("A" & 行數變量)) = 10 Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 4)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 2) = "B0" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 2)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 2) = "B1" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 2)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 2) = "B2" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 2)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 2) = "B3" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 2)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 2) = "B4" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 2)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 2) = "B5" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 2)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 2) = "B6" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 2)
ElseIf Len(Range("A" & 行數變量)) = 13 And Left(Range("A" & 行數變量), 4) = "B999" Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 6)
ElseIf Len(Range("A" & 行數變量)) = 13 Then
Range("B" & 行數變量) = Mid(Range("A" & 行數變量), 1, 3)
Else
End If
Next
'根據物料編碼大類，取物料大類與計劃員、備件類别對應關系
Dim e, sr, sl As Integer
With Sheets("臨時表")
'sl = .Range("a65536").End(3).Row '進度條最大值設定
'插入進度條
For e = 2 To 有效行數
DoEvents
ProgressBar1.Value = e '進度條步行
ProgressBar1.Max = 有效行數 '進度條最大值設定
Label2.Caption = "正在進行物料類碼與計劃員、備件類别對應關系處理，請稍後....."
sr = Cells(e, 2)
Cells(e, 3) = Sheets("物料大類與計劃員、備件類别關系").Cells.Find(sr, , , 1).Offset(0, 1)
Cells(e, 4) = Sheets("物料大類與計劃員、備件類别關系").Cells.Find(sr, , , 2).Offset(0, 2)
Next
End With
'庫存資料統計：分别為按照大類統計庫存、按照計劃員統計庫存、按照備件類别統計庫存
Dim arr, brr(1 To 10000, 1 To 5), crr(1 To 10000, 1 To 4), drr(1 To 10000, 1 To 4)
Dim i As Long, j As Long, k As Long, m As Long, n As Long, l As Long, f As Long
Dim d1, d2, d3, s1, s2
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
arr = Sheets("臨時表").Range("a1").CurrentRegion
'插入進度條處理
Dim jdt2%
For jdt2 = 2 To 有效行數 'UBound(arr)
DoEvents
ProgressBar1.Max = 有效行數 'UBound(arr) '設定進度條控件的最大值
ProgressBar1.Value = jdt2 '進度條控件對象的目前值 '用它插入到運作程式的各處。
Label2.Caption = "正在進行庫存資料統計處理，請稍後......"
Next
'統計庫存資料程式
For i = 2 To UBound(arr)
If d1.exists(arr(i, 2)) Then
m = d1(arr(i, 2))
brr(m, 4) = brr(m, 4) + arr(i, 9) '8
brr(m, 5) = brr(m, 5) + arr(i, 12) '11
Else
j = j + 1
d1(arr(i, 2)) = j
brr(j, 1) = j
brr(j, 2) = arr(i, 2)
brr(j, 3) = arr(i, 3)
brr(j, 4) = arr(i, 9) '8
brr(j, 5) = arr(i, 12) '11
End If
If d2.exists(arr(i, 3)) Then
n = d2(arr(i, 3))
crr(n, 3) = crr(n, 3) + Round(arr(i, 9), 0)
crr(n, 4) = crr(n, 4) + arr(i, 12)
Else
k = k + 1
d2(arr(i, 3)) = k
crr(k, 1) = k
crr(k, 2) = arr(i, 3)
crr(k, 3) = arr(i, 9)
crr(k, 4) = arr(i, 12)
End If
If d3.exists(arr(i, 4)) Then
l = d3(arr(i, 4))
drr(l, 3) = drr(l, 3) + Round(arr(i, 9), 0)
drr(l, 4) = drr(l, 4) + arr(i, 12)
Else
f = f + 1
d3(arr(i, 4)) = f
drr(f, 1) = f
drr(f, 2) = arr(i, 4)
drr(f, 3) = arr(i, 9)
drr(f, 4) = arr(i, 12)
End If
Next
For i = 1 To j
brr(i, 5) = Round(brr(i, 5) / 10000, 2)
s1 = s1 + brr(i, 4)
s2 = s2 + brr(i, 5)
Next
brr(j + 1, 1) = "合計"
brr(j + 1, 4) = s1
brr(j + 1, 5) = s2
s1 = 0: s2 = 0
For i = 1 To k
crr(i, 4) = Round(crr(i, 4) / 10000, 2)
s1 = s1 + crr(i, 3)
s2 = s2 + crr(i, 4)
Next
crr(k + 1, 1) = "合計"
crr(k + 1, 3) = s1
crr(k + 1, 4) = s2
s1 = 0: s2 = 0
For i = 1 To f
drr(i, 4) = Round(drr(i, 4) / 10000, 2)
s1 = s1 + drr(i, 3)
s2 = s2 + drr(i, 4)
Next
drr(f + 1, 1) = "合計"
drr(f + 1, 3) = s1
drr(f + 1, 4) = s2
With Sheets("按照大類統計庫存彙總表")
.Range("a3:e65536").ClearContents
.Range("a3").Resize(j + 1, 5) = brr
End With
With Sheets("按照計劃員統計庫存彙總表")
.Range("a3:d65536").ClearContents
.Range("a3").Resize(k + 1, 4) = crr
End With
With Sheets("按照備件類别統計庫存彙總表")
.Range("a3:d65536").ClearContents
.Range("a3").Resize(f + 1, 4) = drr
End With
Label2.Caption = "庫存資料統計已完成......"
有效行數 = Sheet1.UsedRange.Rows.Count
有效行數101 = Sheet2.UsedRange.Rows.Count
Label3.Caption = "本次執行的庫存行資料共有" & 有效行數 - 1 & "條,庫存總金額共計" & Sheets("按照大類統計庫存彙總表").Cells(有效行數101, 5) & "萬元,請您校驗!"
MsgBox "恭喜您,庫存資料統計完成"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub CommandButton6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
CommandButton6.BackColor = &H8000000D
End Sub
Private Sub CommandButton7_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) '庫存執行按鈕
CommandButton7.BackColor = &H8000000D
End Sub