|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 liusenbog 于 2023-3-29 17:17 编辑
需要删除 材料汇总 四个金额列 删除后数据不对应 不知道如何修改 劳烦f各位大神指教！！
Sub ff_QuanZhang()
Dim X As Date
Dim Y As Date
If Trim(CStr(Range("B3").Value)) = "" Then
X = CDate("1900-01-01")
Else
If IsDate(Trim(CStr(Range("B3").Value))) Then
X = CDate(Trim(CStr(Range("B3").Value)))
Else
MsgBox "输入的起始日期不正确，请认真核对！", 48, "系统提示"
Range("B3").Select
Exit Sub
End If
End If
If Trim(CStr(Range("B4").Value)) = "" Then
Y = CDate("2100-12-31")
Else
If IsDate(Trim(CStr(Range("B4").Value))) Then
Y = CDate(Trim(CStr(Range("B4").Value)))
Else
MsgBox "输入的结束日期不正确，请认真核对！", 48, "系统提示"
Range("B4").Select
Exit Sub
End If
End If
If Y < X Then
MsgBox "输入的结束日期不能小于开始日期，请认真核对！", 48, "系统提示"
Range("B3").Select
Exit Sub
End If
Application.ScreenUpdating = False
Range("A8:N" & Rows.Count).ClearContents
Range("A8:N" & Rows.Count).Borders.LineStyle = xlNone
Range("A8:N" & Rows.Count).Interior.ColorIndex = xlNone
Dim d As Object, arr, crr, brr()
Dim i As Long
Dim j As Long
Dim m As Long
Dim k As Long
Dim key As String
Set d = CreateObject("scripting.dictionary")
If Sheet1.Range("C" & Sheet1.Rows.Count).End(xlUp).Row < 4 Then Exit Sub
crr = Sheet1.Range("C4:K" & Sheet1.Range("C" & Sheet1.Rows.Count).End(xlUp).Row)
ReDim brr(1 To UBound(crr), 1 To 17)
Dim HuoHang As Long
HuoHang = UBound(crr)
Dim ShuHang As Long
Dim ZongHang As Long
ZongHang = HuoHang + ShuHang
Dim JiHang As Long
JiHang = 0
For j = 1 To HuoHang
key = Trim(CStr(crr(j, 1)))
If Not d.exists(key) Then
m = m + 1
d(key) = m
brr(m, 1) = crr(j, 1)
brr(m, 2) = crr(j, 2)
brr(m, 3) = crr(j, 3)
brr(m, 4) = crr(j, 7)
brr(m, 5) = crr(j, 9)
brr(m, 6) = 0
brr(m, 7) = 0
brr(m, 8) = 0
brr(m, 9) = 0
brr(m, 10) = crr(j, 7)
brr(m, 11) = 0
brr(m, 12) = 0
brr(m, 13) = crr(j, 6)
brr(m, 14) = 0
brr(m, 15) = 0
brr(m, 16) = 0
brr(m, 17) = 0
Else
ZongHang = ZongHang - 1
End If
Next
arr = Sheet5.Range("A2:L" & Sheet5.Range("A" & Sheet5.Rows.Count).End(xlUp).Row)
ShuHang = UBound(arr)
For i = 1 To ShuHang
key = Trim(CStr(arr(i, 5)))
If d.exists(key) Then
If CDate(Trim(CStr(arr(i, 1)))) < X Then
brr(d(key), 4) = brr(d(key), 4) + arr(i, 8) '数量
brr(d(key), 5) = brr(d(key), 5) + arr(i, 10) '金额
brr(d(key), 10) = Val(brr(d(key), 10)) + Val(arr(i, 8)) '数量
End If
If CDate(Trim(CStr(arr(i, 1)))) >= X And CDate(Trim(CStr(arr(i, 1)))) <= Y Then
brr(d(key), 6) = brr(d(key), 6) + arr(i, 8) '数量
brr(d(key), 7) = brr(d(key), 7) + arr(i, 10) '金额
brr(d(key), 10) = Val(brr(d(key), 10)) + Val(arr(i, 8)) '数量
End If
brr(d(key), 15) = Val(brr(d(key), 15)) + Val(arr(i, 8)) '数量
brr(d(key), 16) = Val(brr(d(key), 16)) + Val(arr(i, 10)) '金额
End If
Next
arr = Sheet8.Range("A2:L" & Sheet8.Range("A" & Sheet8.Rows.Count).End(xlUp).Row)
ShuHang = UBound(arr)
For i = 1 To ShuHang
key = Trim(CStr(arr(i, 5)))
If d.exists(key) Then
If CDate(Trim(CStr(arr(i, 1)))) < X Then
brr(d(key), 4) = brr(d(key), 4) - arr(i, 8)
brr(d(key), 17) = brr(d(key), 17) + arr(i, 8) '数量
brr(d(key), 10) = Val(brr(d(key), 10)) - Val(arr(i, 8))
End If
If CDate(Trim(CStr(arr(i, 1)))) >= X And CDate(Trim(CStr(arr(i, 1)))) <= Y Then
brr(d(key), 8) = brr(d(key), 8) + arr(i, 8)
brr(d(key), 9) = brr(d(key), 9) + arr(i, 10)
brr(d(key), 10) = Val(brr(d(key), 10)) - Val(arr(i, 8))
End If
End If
Next
For i = 1 To m
Dim huoShu As Double
Dim huoJin As Double
Dim junJia As Double
huoShu = Val(brr(i, 15))
huoJin = Val(brr(i, 16))
If huoShu <> 0 And huoJin <> 0 Then
junJia = huoJin / huoShu
brr(i, 12) = junJia
brr(i, 5) = Val(brr(i, 5)) - (Val(brr(i, 17)) * junJia)
brr(i, 12) = junJia
brr(i, 11) = Val(brr(i, 10)) * junJia
End If
If Val(brr(i, 13)) <> 0 Then
If Val(brr(i, 10)) < Val(brr(i, 13)) Then
brr(i, 14) = "急缺"
End If
Else
brr(i, 14) = ""
End If
Next
Range("A8").Resize(m, 14) = brr
Range("A8").Resize(m + 1, 14).Borders.LineStyle = xlContinuous
Cells(m + 8, 1) = "合计:"
Cells(m + 8, 4) = "=SUBTOTAL(9,D8:D" & CStr(m + 7) & ")"
Cells(m + 8, 5) = "=SUBTOTAL(9,E8:E" & CStr(m + 7) & ")"
Cells(m + 8, 6) = "=SUBTOTAL(9,F8:F" & CStr(m + 7) & ")"
Cells(m + 8, 7) = "=SUBTOTAL(9,G8:G" & CStr(m + 7) & ")"
Cells(m + 8, 8) = "=SUBTOTAL(9,H8:H" & CStr(m + 7) & ")"
Cells(m + 8, 9) = "=SUBTOTAL(9,I8:I" & CStr(m + 7) & ")"
Cells(m + 8, 10) = "=SUBTOTAL(9,J8:J" & CStr(m + 7) & ")"
Cells(m + 8, 11) = "=SUBTOTAL(9,K8:K" & CStr(m + 7) & ")"
Set d = Nothing
Set arr = Nothing
Set crr = Nothing
Erase brr
'End With
Range(Cells(m + 7 + 1, "A"), Cells(m + 7 + 1, "N")).Interior.ColorIndex = 35
Application.ScreenUpdating = True
End Sub
补充内容 (2023-4-2 08:46):
求助各位大神帮忙看看 |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-3-29 17:15
楼主