求助自动录入问题

Excelgogogogo

需求写在附件里

3190496160

Sub 文本框5_Click()
Dim ar As Variant
Dim br(), cr()
With Sheets("派工")
    r = .Cells(Rows.Count, 3).End(xlUp).Row
    If r < 4 Then MsgBox "派工为空！": End
    ar = .Range("a1:d" & r)
    rq = .[c2]
    bz = .[g2]
    bc = .[m2]
End With
ReDim br(1 To UBound(ar), 1 To 1)
ReDim cr(1 To UBound(ar), 1 To 4)
For i = 4 To UBound(ar)
    If Trim(ar(i, 3)) <> "" Then
        n = n + 1
        br(n, 1) = ar(i, 3)
        cr(n, 1) = ar(i, 4)
        cr(n, 2) = ar(i, 2)
        cr(n, 3) = bz
        cr(n, 4) = bc
    End If
Next i
With Sheets("报工")
    rs = .Cells(Rows.Count, 3).End(xlUp).Row + 1
    .Cells(rs, 1).Resize(n, 1) = rq
    .Cells(rs, 3).Resize(n, 1) = br
    .Cells(rs, 6).Resize(n, 4) = cr
End With
End Sub

3190496160

3190496160

求助.rar (30.82 KB, 下载次数: 17)

2023-5-21 09:43 上传

点击文件名下载附件

gwjkkkkk

Sub TEST2()
    Dim ar, br, cr, i&, j&, r&, iRow&
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To 9)
    cr = Array(7, 3, 6)
    For i = 4 To UBound(ar)
        If ar(i, 3) <> "" Then
            r = r + 1
            For j = 0 To UBound(cr)
                br(r, cr(j)) = ar(i, j + 2)
            Next j
            br(r, 1) = Cells(2, 3).Value
            br(r, 8) = Cells(2, 7).Value
            br(r, 9) = Cells(2, 13).Value
        End If
    Next i
    With Sheets(2)
        iRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        .Cells(iRow, 1).Resize(r, 9) = br
        .Columns(1).NumberFormatLocal = "m月d日"
        .Activate
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。