|
代码新写一个。
- Sub ykcbf() '//2024.5.9
- Set d = CreateObject("Scripting.Dictionary")
- Application.ScreenUpdating = False '关闭屏幕刷新
- Application.DisplayAlerts = False
- p = ThisWorkbook.Path & ""
- Dim tm: tm = Timer
- Set sh = ThisWorkbook.Sheets("Sheet1")
- With sh
- r = .Cells(Rows.Count, 1).End(xlUp).Row
- col = .UsedRange.Columns.Count
- arr = .[a1].Resize(r, col)
- dm = .[b2].Value
- End With
- For j = 12 To UBound(arr, 2)
- s = Format(arr(4, j), "m月d日")
- d(s) = ""
- Next
- For Each k In d.keys
- sh.Copy
- Set wb = ActiveWorkbook
- With wb.Sheets(1)
- .Name = k
- .DrawingObjects.Delete
- .[g:az].Delete
- .[a1] = "物料清单"
- .[a3] = "物料日期:"
- .[f4] = "领用数量"
- .[b3] = k
- .[c3].Resize(1, 4) = ""
- .UsedRange.Offset(4).Clear
- m = 0
- ReDim brr(1 To UBound(arr), 1 To 6)
- For j = 12 To UBound(arr, 2)
- If Format(arr(4, j), "m月d日") = k Then c = j
- Next
- For i = 5 To UBound(arr)
- If arr(i, c) <> Empty Then
- m = m + 1
- brr(m, 1) = m
- For j = 2 To 5
- brr(m, j) = arr(i, j)
- Next
- brr(m, 6) = arr(i, c)
- End If
- Next
- .[a5].Resize(m, 6) = brr
- End With
- wb.SaveAs p & dm & "领料" & "-" & k
- wb.Close 1
- Next
- Set d = Nothing
- Application.ScreenUpdating = True '开启屏幕刷新
- MsgBox "共用时:" & Format(Timer - tm) & "秒!"
- End Sub
复制代码
|
评分
-
2
查看全部评分
-
|