请教各位大神更改进销存表格

liusenbog

需要删除 材料汇总 四个金额列  删除后数据不对应  不知道如何修改 劳烦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):
求助各位大神帮忙看看

zhumin1025

删除了结构有变化，改起来很麻烦，如果嫌眼花，你把这4列隐藏了就可以，想要的时候再放出来

liusenbog

zhumin1025 发表于 2023-4-3 19:23
删除了结构有变化，改起来很麻烦，如果嫌眼花，你把这4列隐藏了就可以，想要的时候再放出来

嗯嗯  我就是想学习下如何修改  如果后期真的没人回复 我就只能隐藏了  谢谢您的回复 感恩！

liusenbog

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



路过的大神帮忙看下这个表示什么  有点看不懂