请大神帮忙修改代码

quqiyuan

代码如下。。。
Sub 入库()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim ar As Variant
    Dim br()
    Dim rowCount As Long
    Dim ws As Worksheet
    Set ws = Worksheets("车票出入库")
    rs = ws.Cells(Rows.Count, 2).End(xlUp).Row
    If rs < 2 Then MsgBox "请先录入数据!": End
    ar = ws.Range("a1:b" & rs)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            n = n + 1
            br(n, 1) = Format(Date, "m-d")
            For j = 1 To UBound(ar, 2)
                br(n, j + 1) = ar(i, j)
            Next j
        End If
    Next i
    If n = "" Then MsgBox "数据源为空,请先录入数据!": End
    With ws
        r = .Cells(Rows.Count, "h").End(xlUp).Row + 1
        .Cells(r, "h").Resize(n, UBound(br, 2)) = br
    End With
    If Len(ws.[f2].Value) > 0 Then
        With Sheets("车票结存")
            cr = .[i1].CurrentRegion
            dr = Application.Index(cr, 1)
            x = Application.Match(ws.[f2].Value, .Columns("i"), 0)
            For i = 1 To n
                y = Application.Match(br(i, 2), dr, 0)
                cr(x, y) = Empty
            Next
            .[i1].CurrentRegion = cr
        End With
    End If
    ws.Range("B2:B" & rs).ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub


Sub 出库()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim ar As Variant
    Dim br()
    Dim rowCount As Long
    Dim ws As Worksheet
    Set ws = Worksheets("车票出入库")
    rs = ws.Cells(Rows.Count, 3).End(xlUp).Row
    If rs < 2 Then MsgBox "请先录入数据!": End
    ar = ws.Range("a1:c" & rs)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) <> "" Then
            n = n + 1
            br(n, 1) = Format(Date, "m-d")
            br(n, 2) = ar(i, 1)
            br(n, 3) = ar(i, 3)
        End If
    Next i
    If n = "" Then MsgBox "数据源为空,请先录入数据!": End
    With ws
        r = ws.Cells(Rows.Count, "k").End(xlUp).Row + 1
        .Cells(r, "k").Resize(n, UBound(br, 2)) = br
    End With
    If Len(ws.[f2].Value) > 0 Then
        With Sheets("车票结存")
            cr = .[i1].CurrentRegion
            dr = Application.Index(cr, 1)
            x = Application.Match(ws.[f2].Value, .Columns("i"), 0)
            For i = 1 To n
                y = Application.Match(br(i, 2), dr, 0)
                cr(x, y) = cr(x, y) + br(i, 3)
            Next
            .[i1].CurrentRegion = cr
        End With
    End If
    ws.Range("c2:c" & rs).ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

divineson

quqiyuan 发表于 2024-9-21 12:40

感谢大神，就是需要实现这种效果。测试了一下，发现如不录入对应车票类型的数据，结存表中无法清空，如录入“0”又会在“出入库”表中增加一条空白的数据，麻烦大神再出手优化一下，只要是“出入表”F2选中的名字则结存表中对应的整行车票数据都清空，万分感谢！

quqiyuan

调整好了，仅供参考。。。

quqiyuan

代码如下。。。
Sub 入库()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim ar As Variant
    Dim br()
    Dim rowCount As Long
    Dim ws As Worksheet
    Set ws = Worksheets("车票出入库")
    rs = ws.Cells(Rows.Count, 2).End(xlUp).Row
    If rs < 2 Then MsgBox "请先录入数据!": End
    ar = ws.Range("a1:b" & rs)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If ar(i, 2) <> Empty Then
            n = n + 1
            br(n, 1) = Format(Date, "m-d")
            For j = 1 To UBound(ar, 2)
                br(n, j + 1) = ar(i, j)
            Next j
        End If
    Next i
    If n = "" Then MsgBox "数据源为空,请先录入数据!": End
    With ws
        r = .Cells(Rows.Count, "h").End(xlUp).Row + 1
        .Cells(r, "h").Resize(n, UBound(br, 2)) = br
    End With
    If Len(ws.[f2].Value) > 0 Then
        With Sheets("车票结存")
            cr = .[i1].CurrentRegion
            dr = Application.Index(cr, 1)
            x = Application.Match(ws.[f2].Value, .Columns("i"), 0)
            For i = 2 To UBound(cr, 2)
                cr(x, i) = Empty
            Next
            .[i1].CurrentRegion = cr
        End With
    End If
    ws.Range("B2:B" & rs).ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub


Sub 出库()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim ar As Variant
    Dim br()
    Dim rowCount As Long
    Dim ws As Worksheet
    Set ws = Worksheets("车票出入库")
    rs = ws.Cells(Rows.Count, 3).End(xlUp).Row
    If rs < 2 Then MsgBox "请先录入数据!": End
    ar = ws.Range("a1:c" & rs)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If ar(i, 3) <> Empty Then
            n = n + 1
            br(n, 1) = Format(Date, "m-d")
            br(n, 2) = ar(i, 1)
            br(n, 3) = ar(i, 3)
        End If
    Next i
    If n = "" Then MsgBox "数据源为空,请先录入数据!": End
    With ws
        r = ws.Cells(Rows.Count, "k").End(xlUp).Row + 1
        .Cells(r, "k").Resize(n, UBound(br, 2)) = br
    End With
    If Len(ws.[f2].Value) > 0 Then
        With Sheets("车票结存")
            cr = .[i1].CurrentRegion
            dr = Application.Index(cr, 1)
            x = Application.Match(ws.[f2].Value, .Columns("i"), 0)
            For i = 1 To n
                y = Application.Match(br(i, 2), dr, 0)
                cr(x, y) = cr(x, y) + br(i, 3)
            Next
            .[i1].CurrentRegion = cr
        End With
    End If
    ws.Range("c2:c" & rs).ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

divineson

quqiyuan 发表于 2024-9-21 19:35
代码如下。。。
Sub 入库()
    Application.ScreenUpdating = False '关闭屏幕刷新

感谢大神，完全实现我想要的功能，鲜花已送上，再次感谢大神的帮忙！