求助，VBA添加无编码的存货并自动编码

elong185 · 发表于 2024-8-1 18:28

复制无编码的F列和G列，添加到Sheet2的B列和C列

并继续编码

gwjkkkkk · 发表于 2024-8-1 19:15

Option Explicit
Sub TEST1()
Dim ar, br, i&, j&, r&, m&, n&

ar = Worksheets(2).[A1].CurrentRegion.Value

ReDim br(1 To UBound(ar), 1 To 3)

For i = 3 To UBound(ar)
      If Len(ar(i, 5)) = 0 Then
         r = r + 1
         For j = 5 To 7
            br(r, j - 4) = ar(i, j)
         Next j
      End If
Next i

If r Then
      With Worksheets(1)
         n = .Cells(.Rows.Count, "A").End(xlUp).Row
         m = .Cells(n, 1).Value
         n = n + 1
         For i = m + 1 To m + r
            br(i - m, 1) = i
         Next i
         .Cells(n, 1).Resize(r, 3) = br
         .Activate
      End With
End If

Beep
End Sub

gwjkkkkk · 发表于 2024-8-1 19:16

。。。。。。。。。。。。

ykcbf1100 · 发表于 2024-8-1 19:56

参与一下。。。

ykcbf1100 · 发表于 2024-8-1 19:57

参与一下。。。

Sub ykcbf() '//2024.8.1
With Sheets("采购进货")
r = .Cells(Rows.Count, 6).End(3).Row
arr = .[e1].Resize(r, 3)
r1 = .Cells(Rows.Count, 5).End(3).Row
mm = Val(.Cells(r1, 5))
End With
ReDim brr(1 To r, 1 To 3)
For i = 3 To UBound(arr)
If arr(i, 1) = Empty Then
m = m + 1
brr(m, 1) = mm + m
brr(m, 2) = arr(i, 2)
brr(m, 3) = arr(i, 3)
End If
Next
With Sheets("存货")
r = .Cells(Rows.Count, 1).End(3).Row
.Cells(r + 1, 1).Resize(m, 3) = brr
End With
MsgBox "OK！"
End Sub

复制代码

leeson7502 · 发表于 2024-8-1 20:40

提示: 作者被禁止或删除内容自动屏蔽

elong185 · 发表于 2024-8-2 08:09

gwjkkkkk 发表于 2024-8-1 19:15
Option Explicit
Sub TEST1()
Dim ar, br, i&, j&, r&, m&, n&

感谢！！！！

		自动登录	找回密码
密码			免费注册

[求助] 求助，VBA添加无编码的存货并自动编码

评分

评分

评分

leeson7502 leeson7502 当前离线性别保密 UID 66230 阅读权限 0 注册时间 2005-2-19 在线时间小时最后登录 1970-1-1 积分 446 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	发表于 2024-8-1 20:40 \| 显示全部楼层 [广告] ★ 造就Excel高手的神器，远胜VBA/Python ★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报