[已解决]求一个VBA，谢谢各位大大。。。。万分感谢！！

che_dream

求一个VBA，谢谢各位大大。。。。万分感谢！！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-4-12 12:04

Sub Macro2()
On Error Resume Next
Dim arr, brr, d, i%, j&, s&
Set d = CreateObject("scripting.dictionary")
Sheets("表五").Activate
ActiveSheet.UsedRange.Clear
arr = Sheet1.Range("a2").CurrentRegion
For i = 3 To 6
    brr = Sheets(i).Range("a3").CurrentRegion
    For j = 2 To UBound(brr)
        d(brr(j, 1)) = ""
    Next
Next
s = 3
Sheet1.[a2].Resize(1, 7).Copy [a3]
For j = 2 To UBound(arr)
    If Not d.exists(arr(j, 1)) Then
        s = s + 1
        Sheet1.Cells(j + 1, 1).Resize(1, 7).Copy Cells(s, 1)
    End If
Next
End Sub

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, d, i&, h&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a2").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     d(arr(i, 1)) = i + 1
   
7. Next
   
8. For i = 4 To Range("a65536").End(xlUp).Row
   
9.     h = d(Cells(i, 1).Value)
   
10.     Sheet1.Cells(h, 2).Resize(1, 6).Copy Cells(i, 2)
    
11. Next
    
12. End Sub
    

复制代码

dsmch

………………

yuan1987

学习了

fjmxwrs

你是想填写即时库存表，还是什么？？讲清楚你这表是何用途。

che_dream

dsmch 发表于 2014-4-10 17:49
………………

表一中有空行的时候会报错，还有即时库存中没有，表一中有的也会报错，帮我改改 ，谢谢，我想用同样的方法建表二，表三，表四，然后把即时库存中没有出现在表一，表二，表三，表四的物料自动导入到“未出现在表一表二表三表四的物料”中。谢谢。

che_dream

fjmxwrs 发表于 2014-4-10 18:18
你是想填写即时库存表，还是什么？？讲清楚你这表是何用途。

我已经重新更改了，谢谢。

dsmch

1. Sub Macro1()
   
2. Dim arr, d, i&, h&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a2").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     d(arr(i, 1)) = i + 1
   
7. Next
   
8. For i = 4 To Range("a65536").End(xlUp).Row
   
9.     If d.exists(Cells(i, 1).Value) Then
   
10.         h = d(Cells(i, 1).Value)
    
11.         Sheet1.Cells(h, 2).Resize(1, 6).Copy Cells(i, 2)
    
12.     End If
    
13. Next
    
14. End Sub
    

复制代码

建议完善附件并模拟结果

che_dream

dsmch 发表于 2014-4-11 12:55
建议完善附件并模拟结果

谢谢，已经完善附件了，帮我看看，谢谢。。

dsmch

1. Sub Macro2()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, i%, j&, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Sheets("表五").Activate
   
6. ActiveSheet.UsedRange.Clear
   
7. arr = Sheet1.Range("a2").CurrentRegion
   
8. For i = 2 To 5
   
9.     brr = Sheets(i).Range("a3").CurrentRegion
   
10.     For j = 2 To UBound(brr)
    
11.         d(brr(j, 1)) = ""
    
12.     Next
    
13. Next
    
14. s = 3
    
15. Sheet1.[a2].Resize(1, 7).Copy [a3]
    
16. For j = 2 To UBound(arr)
    
17.     If Not d.exists(arr(j, 1)) Then
    
18.         s = s + 1
    
19.         Sheet1.Cells(j + 1, 1).Resize(1, 7).Copy Cells(s, 1)
    
20.     End If
    
21. Next
    
22. End Sub
    

复制代码