vba优化运行速度
Sub hz1() 'SHL 汇总
Application.ScreenUpdating = False '刷新
Application.DisplayAlerts = False '警告框
On Error Resume Next
Dim i As Long, j As Long, k%, clast%, blast%, dlast%
Dim dbook As Workbook, sht As Worksheet, asht As Worksheet, bsht As Worksheet, csht As Worksheet, dsht As Worksheet, tsht As Worksheet
Dim qmdz1 As String
Dim fso As Object
Dim mainFolder As Object
Dim subFolder As Object
Dim file As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim folderPath As String
Dim filePath As String
For Each sht In ThisWorkbook.Worksheets
sht.Visible = True
Next
Set csht = ThisWorkbook.Sheets("SHL保管率(全体)")
'Set asht = ThisWorkbook.Sheets("Map")
Set esht = ThisWorkbook.Sheets("SHL①平铺")
Set fsht = ThisWorkbook.Sheets("SHL②小货架")
Set gsht = ThisWorkbook.Sheets("SHL③高层货架")
a = csht.Range("E1") '年
b = csht.Range("F1") '月
c = csht.Range("E2") '年
d = csht.Range("F2") '月
f = csht.Range("G1") '日
g = csht.Range("G2") '日
e = csht.Range("B2") '请款方
If a <> "" And b <> "" And c <> "" And d <> "" And f <> "" And g <> "" Then
a3 = a & "/" & b & "/" & f & "-" & c & "/" & d & "/" & g '年月日-年月日
nd1 = Val(a) '起始年
nd2 = Val(c) '结束年
nd3 = Val(b) '起始月
nd4 = Val(d) '结束月
nd5 = Val(f) '起始日
nd6 = Val(g) '结束日
edoo = esht.Cells(3, Columns.Count).End(xlToLeft).Column '最后一列
If (nd1 = nd2) And (nd3 = nd4) And (nd3 <> Val(Format(Date, "m"))) Then '非本月 Then
For Each sht In ThisWorkbook.Worksheets
If sht.Name Like "*" & e & "*" And Not sht.Name Like "*全体*" Then
sht.Range(sht.Cells(4, 9), sht.Cells(7, edoo)) = "0"
sht.Range(sht.Cells(25, 9), sht.Cells(28, edoo)) = "0"
If sht.Name Like "*" & e & "*平铺*" Or sht.Name Like "*" & e & "*高层货架*" Then
sht.Range(sht.Cells(4, 9), sht.Cells(8, edoo)) = "0"
End If
AA = 1
End If
Next
ElseIf (nd1 = nd2) And (nd3 = nd4) And (nd3 = Val(Format(Date, "m"))) Then
For Each sht In ThisWorkbook.Worksheets
If sht.Name Like "*" & e & "*" And Not sht.Name Like "*全体*" Then
sht.Activate
sht.Range(sht.Cells(4, nd5 + 8), sht.Cells(7, nd6 + 8)) = "0"
sht.Range(sht.Cells(25, nd5 + 8), sht.Cells(28, nd6 + 8)) = "0"
If sht.Name Like "*" & e & "*平铺*" Or sht.Name Like "*" & e & "*高层货架*" Then
sht.Range(sht.Cells(4, nd5 + 8), sht.Cells(8, nd6 + 8)) = "0"
End If
AA = 1
End If
Next
Else
MsgBox "请重新输入年月日!"
Exit Sub
End If
If AA = 1 Then
qmdz1 = "\\desktop\1.Draft\"
qmdz2 = qmdz1 & nd1 & "年度\" & nd3 & "月\"
folderPath = qmdz2
' qmdz3 = qmdz2 & "PARTS\"
' qmdz4 = qmdz2 & "PRODUCTS\"
' qmdz5 = qmdz2 & "辅材\"
esht.Activate
For ko = nd5 To nd6
If ko = 1 Then '2025/n/1
If nd3 = 1 Then
ny = (nd1 - 1) & "12" & "31"
ny1 = nd1 & "0" & nd3 & "01"
ElseIf nd3 <> 1 And nd3 <= 10 Then
If (nd3 - 1) = 1 Or (nd3 - 1) = 3 Or (nd3 - 1) = 5 Or (nd3 - 1) = 7 Or (nd3 - 1) = 8 Then
ny = nd1 & "0" & (nd3 - 1) & "31"
ElseIf (nd3 - 1) = 4 Or (nd3 - 1) = 6 Or (nd3 - 1) = 9 Then
ny = nd1 & "0" & (nd3 - 1) & "30"
ElseIf (nd3 - 1) = 2 Then
ny = nd1 & "0" & (nd3 - 1) & "28"
End If
ny1 = nd1 & "0" & nd3 & "" & "01"
ElseIf nd3 > 10 And nd3 <= 12 Then
If (nd3 - 1) = 10 Then
ny = nd1 & (nd3 - 1) & "31"
ElseIf (nd3 - 1) = 11 Then
ny = nd1 & (nd3 - 1) & "30"
End If
ny1 = nd1 & nd3 & "01"
End If
ElseIf ko <> 1 And ko <= 10 Then '
If nd3 >= 1 And nd3 < 10 Then
ny = nd1 & "0" & nd3 & "0" & (ko - 1)
ny1 = nd1 & "0" & nd3 & "0" & ko
ElseIf nd3 >= 10 And nd3 <= 12 Then
ny = nd1 & nd3 & "0" & (ko - 1)
ny1 = nd1 & nd3 & "0" & ko
End If
ElseIf ko > 10 And ko <= 31 Then '
If nd3 >= 1 And nd3 < 10 Then
ny = nd1 & "0" & nd3 & (ko - 1)
ny1 = nd1 & "0" & nd3 & ko
ElseIf nd3 >= 10 And nd3 <= 12 Then
ny = nd1 & nd3 & (ko - 1)
ny1 = nd1 & nd3 & ko
End If
End If
'所转数据的表头日期
' nyn = Left(ny, 4) '年
' nyy = Mid(ny, 5, 2) '月
' nyr = Right(ny, 2) '日
With esht
edoo = .Cells(3, Columns.Count).End(xlToLeft).Column '最后一列
For ho = edoo To 9 Step -1
If Val(.Cells(3, ho)) = ko Then
ho1 = ho
Exit For
End If
Next ho
End With
qmdz3 = qmdz2
Filename = Dir(qmdz3)
Do While Filename <> ""
Name1 = Filename
If Name1 Like "INVENTORY*SONGHAN*" & ny & "*" Then '获取当月的draft
gon = Name1
If gon <> "" Then
qmdz = qmdz3 & gon
Set dbook = Workbooks.Open(qmdz) '打开draft1
For Each sht In dbook.Worksheets
If sht.Name Like "INVENTORY*SONGHAN*" & ny & "*" Then
sht.Activate
sht.AutoFilterMode = False '取消筛选
ro1 = "": ro2 = "": doo = "": dlast = ""
With sht
dlast1 = .Cells(Rows.Count, 1).End(3).Row 'draft1的最后一行
dlast2 = .Cells(Rows.Count, 3).End(3).Row 'draft1的最后一行
If dlast1 < dlast2 Then
dlast = dlast2
Else
dlast = dlast1
End If
ro1 = 1
ro2 = dlast
doo = .Cells(ro1, Columns.Count).End(xlToLeft).Column 'draft最后一列
If (ro1 = "") Or (ro2 = "") Or (doo = "") Then
MsgBox "draft表 未抓取到相关行列,请检查!"
Exit Sub
End If
rolk = "": ko1 = "": ko2 = "": ko3 = "": ko4 = ""
For koo = 1 To doo
If .Cells(ro1, koo) <> "" Then
rolk = .Cells(ro1, koo)
If rolk = "BG-CODE" Then
ko1 = koo
ElseIf rolk = "STOCK-DATE" Then
ko2 = koo
ElseIf rolk = "LOCATION" Then
ko3 = koo
ElseIf rolk = "RECEIVING-LOCATION" Then '判断成品/部品
ko4 = koo
End If
End If
Next
If (ko1 = "") Or (ko2 = "") Or (ko3 = "") Then
MsgBox "draft表 未抓取到相关行列,请检查!"
Exit Sub
End If
.Cells(ro1, doo + 1) = "BG"
.Cells(ro1, doo + 2) = "LA"
.Cells(ro1, doo + 3) = "BG唯一"
.Cells(ro1, doo + 4) = "库位数"
.Cells(ro1, doo + 5) = "OVER库位数"
For k = (ro1 + 1) To dlast
If .Cells(k, ko1) <> "" Then
.Cells(k, doo + 1) = Right(.Cells(k, ko1), 3) '3字BG
If Left(.Cells(k, ko3), 3) = "ZSD" Then '平铺
.Cells(k, doo + 2) = .Cells(k, ko3)
ElseIf Left(.Cells(k, ko3), 1) = "E" Or Left(.Cells(k, ko3), 1) = "F" Then '小货架
.Cells(k, doo + 2) = Left(.Cells(k, ko3), 3)
ElseIf Left(.Cells(k, ko3), 3) = "ZSA" Then '高层
.Cells(k, doo + 2) = .Cells(k, ko3)
End If
ElseIf .Cells(k, ko1) = "" And .Cells(i, ko4) Like "*---*" Then
If Left(.Cells(k, ko3), 3) = "ZSA" Then '高层
.Cells(k, doo + 1) = "FGS"
.Cells(k, doo + 2) = .Cells(k, ko3)
End If
End If
Next
Dim overOneYearCount As Long
Dim oneYearAgo As Date
yt = Val(Left(ny1, 4))
mt = Val(Mid(ny1, 5, 2))
dt = Val(Right(ny1, 2))
gfdg = DateSerial(yt, mt, dt) ' 使用DateSerial函数将年、月、日转换为日期类型
oneYearAgo = CDate(gfdg) - 365
Dim BGDict As Object
Dim LADict As Object
Dim BGName As String
Dim LANumber As String
Dim xdf As String
xdf = ""
For y = 1 To 3
If y = 1 Then
xdf = "ZSD" '平铺
Set tsht = esht
tst = tsht.Cells(Rows.Count, 1).End(3).Row 'draft1的最后一行
ElseIf y = 2 Then
xdf = "E/F" '小货架
Set tsht = fsht
ElseIf y = 3 Then
xdf = "ZSA" '高层
Set tsht = gsht
End If
kse = 1
CC: If kse = 1 Then
nds = "SHL-P" '部品
to1 = 4
to2 = 6
to3 = 25
to4 = 27
ElseIf kse = 2 Then '成品
nds = "SHL-B"
to1 = 7
to2 = to1
to3 = 28
to4 = to3
ElseIf kse = 3 Then '辅材
nds = "---"
to1 = 8
to2 = to1
to3 = 0
to4 = 0
Else
GoTo DD
End If
' 创建字典来存储BG和库位信息
Set BGDict = CreateObject("Scripting.Dictionary")
Set LADict = CreateObject("Scripting.Dictionary")
' 遍历每一行数据
For i = (ro1 + 1) To dlast
If y <> 2 And (.Cells(i, doo + 1) <> "" And .Cells(i, doo + 2) <> "") And (Left(.Cells(i, doo + 2), 3) = xdf) And (.Cells(i, ko4) Like nds & "*") Then '???平铺/小货架/高层+部品/成品/辅材
BGName = .Cells(i, doo + 1).Value
LANumber = .Cells(i, doo + 2).Value
' 检查BG是否已在字典中
If Not BGDict.Exists(BGName) Then
Set BGDict(BGName) = CreateObject("Scripting.Dictionary")
End If
'检查料号是否已在该BG的字典中
If Not BGDict(BGName).Exists(LANumber) Then
BGDict(BGName)(LANumber) = 1 '不存在,添加到字典并设置初始计数为1
Else
BGDict(BGName)(LANumber) = BGDict(BGName)(LANumber) + 1 '存在,则计数加1
End If
' 检查料号是否已在全局料号字典中
If Not LADict.Exists(LANumber) Then
Set LADict(LANumber) = CreateObject("Scripting.Dictionary")
End If
If Not LADict(LANumber).Exists(BGName) Then
LADict(LANumber).Add BGName, 1 ' 添加非重复关系
End If
ElseIf y = 2 And (.Cells(i, doo + 1) <> "" And .Cells(i, doo + 2) <> "") And (Left(.Cells(i, doo + 2), 1) = "E" Or Left(.Cells(i, doo + 2), 1) = "F") And (.Cells(i, ko4) Like nds & "*") Then '???平铺/小货架/高层+部品/成品/辅材
BGName = .Cells(i, doo + 1).Value
LANumber = .Cells(i, doo + 2).Value
' 检查BG是否已在字典中
If Not BGDict.Exists(BGName) Then
Set BGDict(BGName) = CreateObject("Scripting.Dictionary")
End If
'检查料号是否已在该BG的字典中
If Not BGDict(BGName).Exists(LANumber) Then
BGDict(BGName)(LANumber) = 1 '不存在,添加到字典并设置初始计数为1
Else
BGDict(BGName)(LANumber) = BGDict(BGName)(LANumber) + 1 '存在,则计数加1
End If
' 检查料号是否已在全局料号字典中
If Not LADict.Exists(LANumber) Then
Set LADict(LANumber) = CreateObject("Scripting.Dictionary")
End If
If Not LADict(LANumber).Exists(BGName) Then
LADict(LANumber).Add BGName, 1 ' 添加非重复关系
End If
End If
Next i
' 输出不重复的BG
j = ro1 + 1 '从第二行开始
For Each Key In BGDict.Keys
.Cells(j, doo + 3).Value = Key
j = j + 1
Next
Dim idx As Long, tdg As Long
tdg = BGDict.Count '按条件筛选出来的BG数量
If tdg = 0 Then GoTo EE
For i = ro1 To tdg
BGName = .Cells(i + 1, doo + 3).Value
If Len(Trim(BGName)) = 0 Then GoTo SkipIteration ' 跳过空名称
Dim tlt As Double, otlt As Double
tlt = 0: otlt = 0
For Each Key In BGDict(BGName).Keys
If LADict.Exists(Key) Then
Dim djf As Long, shk As Long
djf = LADict(Key).Count '每个料号对应的BG数
shk = BGDict(BGName)(Key) '每个BG同一个料号的个数
jdh = 0
For m = (ro1 + 1) To dlast
hgr1 = Val(Cells(m, ko2).Value)
hgr2 = Val(Format(oneYearAgo, "yyyymmdd"))
If .Cells(m, doo + 1) = BGName And (.Cells(m, doo + 2) = Key) And (Val(Cells(m, ko2).Value) < Val(Format(oneYearAgo, "yyyymmdd"))) Then
jdh = jdh + 1 '每个BG同一个料号 日期超一年的个数
End If
Next m
hrd = 1 '默认个数1
If djf > 0 And hrd > 0 And shk > 0 Then
tlt = tlt + hrd / djf ' 关联BG数量
otlt = otlt + jdh / shk
Else
MsgBox BGName & " " & Key & "在表中存在异常" & sht.Name
Exit Sub
End If
End If
Next
.Cells(i + 1, doo + 4).Value = tlt '库位
.Cells(i + 1, doo + 5).Value = otlt '超1年库位
If tlt < otlt Then
MsgBox "数据抓取异常,请重新转取!"
Exit Sub
End If
SkipIteration:
Next i
For X = (ro1 + 1) To (tdg + 1)
For k = to1 To to2 '平铺/小货架/高层
If .Cells(X, doo + 3) = tsht.Cells(k, 3) Then
tsht.Cells(k, ho1) = tsht.Cells(k, ho1) + .Cells(X, doo + 4)
End If
Next k
For Z = to3 To to4 '超一年 平铺
If .Cells(X, doo + 3) = tsht.Cells(Z, 3) Then
tsht.Cells(Z, ho1) = tsht.Cells(Z, ho1) + .Cells(X, doo + 5)
End If
Next Z
Next X
.Range(.Cells(ro1 + 1, doo + 3), .Cells(tdg + 1, doo + 5)) = ""
EE: Set BGDict = Nothing
Set LADict = Nothing
kse = kse + 1
GoTo CC
DD: Next y
End With
End If
Next
dbook.Close '关闭
Exit Do
End If
End If
Filename = Dir
Loop '符合日期的提取
Next
csht.Activate
csht.Range("m1") = "Generate Date:"
csht.Range("n1") = Format(Now, "yyyy/mm/dd hh:mm:ss")
Call sv
End If
Else
MsgBox "请输入完整的年份和月份!"
Exit Sub
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
最新发布