请大神帮忙修改代码

divineson

请帮忙修改一下代码，实现以下功能：
1.B列录入车票入库数量，点击入库后将“车票名称”和数量录入同表的H、I列中并清空B列数据
2.C列录入车票出库数量，点击出库后将“车票名称”和数量录入同表的K、L列中并清空C列数据
感谢各位大神！

Sub 入库()
Application.ScreenUpdating = False '关闭屏幕刷新
Dim ar As Variant
Dim br()
Dim rowCount As Long
Dim ws As Worksheet
Set ws = Worksheets("车票出入库")
rs = Cells(Rows.Count, 2).End(xlUp).Row
If rs < 2 Then MsgBox "请先录入数据!": End
ar = Range("H1:I" & rs)
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If Trim(ar(i, 2)) <> "" Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
If n = "" Then MsgBox "数据源为空,请先录入数据!": End
With ws
r = ws.Cells(Rows.Count, 9).End(xlUp).Row + 1
.Cells(r, 1).Resize(n, UBound(br, 2)) = br
End With
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 = Cells(Rows.Count, 2).End(xlUp).Row
If rs < 2 Then MsgBox "请先录入数据!": End
ar = Range("H1:I" & rs)
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If Trim(ar(i, 2)) <> "" Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
If n = "" Then MsgBox "数据源为空,请先录入数据!": End
With ws
r = ws.Cells(Rows.Count, 2).End(xlUp).Row + 1
.Cells(r, 1).Resize(n, UBound(br, 2)) = br
End With
Range("B2:B" & rs).ClearContents
Application.ScreenUpdating = True '开启屏幕刷新
End Sub

quqiyuan

发个附件上来吧，这样没办法测试哦

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("a2: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, 9).End(xlUp).Row + 1
        .Cells(r, "g").Resize(n, UBound(br, 2)) = br
    End With
    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("a2: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, 2).End(xlUp).Row + 1
        .Cells(r, "j").Resize(n, UBound(br, 2)) = br
    End With
    Range("c2:c" & rs).ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

divineson

感谢大神，能否帮忙在“出库”增加一个功能，当“车票出入库” F2单元格非空时，将车票数据同步录入到“车票结存“表中对应I列人员姓名行中，将车票数量录入到对应的车票类别列中，如单元格内已录入数据则变为累加，麻烦帮忙看看能否实现该功能，万分感谢！

divineson

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

感谢大神，能否帮忙在“出库”增加一个功能，当“车票出入库” F2单元格非空时，将车票数据同步录入到“车票结存“表中对应I列人员姓名行中，将车票数量录入到对应的车票类别列中，如单元格内已录入数据则变为累加，麻烦帮忙看看能否实现该功能，附件在5楼，万分感谢！

quqiyuan

divineson 发表于 2024-9-20 22:52
感谢大神，能否帮忙在“出库”增加一个功能，当“车票出入库” F2单元格非空时，将车票数据同步录入到 ...

改好了，修正了两个bug，仅供参考。。。

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
    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
    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
    ws.Range("c2:c" & rs).ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

divineson

quqiyuan 发表于 2024-9-21 08:12
改好了，修正了两个bug，仅供参考。。。

大神太强大了，感谢帮忙！按照大神的思路，想在“入库”增加一项清空功能，无奈太菜，怎么也改不出来，还请大神再出手，需求如下：
“车票出入库” F2单元格非空时，检测“车票结存“表中对应I列人员姓名行中车票类别对应列是否有数据，如有则进行清空处理。
麻烦大神再帮忙改改，万分感谢！

quqiyuan

divineson 发表于 2024-9-21 09:20
大神太强大了，感谢帮忙！按照大神的思路，想在“入库”增加一项清空功能，无奈太菜，怎么也改不出来，还 ...