表格内区域复制到sheet2

zhima

将“现场费用”表中筛选出来的各个费用的内容复制到SHEET2中

chaohuahch

供测试：

1. Sub 复制()
   
2. 
   
3. With Sheets("现场费用")
   
4.     nRow = .Range("e" & Rows.Count).End(3).Row
   
5.     arr = .Range("e5:h" & nRow)
   
6. End With
   
7. 
   
8. With Sheets("sheet2")
   
9.     .Columns("A:A").NumberFormatLocal = "@"
   
10.    nrow1 = .Range("a" & Rows.Count).End(3).Row
    
11.    .Range("a" & nrow1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
12. End With
    
13. 
    
14. End Sub
    
15. 
    

复制代码

zhima

chaohuahch 发表于 2018-7-9 16:58
供测试：

谢谢你的回复，测试下来有些小问题呢。
“办公费”，“差旅费”运行之后会将原来的粘贴的内容覆盖，“车辆费”及后续费用会覆盖掉原来粘贴内容的最后一条。

chaohuahch

zhima 发表于 2018-7-9 18:08
谢谢你的回复，测试下来有些小问题呢。
“办公费”，“差旅费”运行之后会将原来的粘贴的内容覆盖，“车 ...

会粘帖会后一天。需要把 nrow1=……+1就可以了。

lenghonghai601

1. Sub test2()
   
2. Dim arr, brr$(), m&, n&, i&, j&
   
3. arr = Worksheets("导出").Range("a2").CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To 4)
   
5. For i = 3 To UBound(arr)
   
6.     For j = 3 To UBound(arr, 2)
   
7.         If arr(i, j) <> 0 Then
   
8.             m = m + 1
   
9.             brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = arr(2, j): brr(m, 4) = arr(i, j)
   
10.         End If
    
11.     Next j
    
12. Next i
    
13. Sheet3.Cells.Clear
    
14. Sheet3.Range("a1").Resize(m, 4) = brr
    
15. 
    
16. End Sub

复制代码

zhima

chaohuahch 发表于 2018-7-10 09:55
会粘帖会后一天。需要把 nrow1=……+1就可以了。

是这样吗
nrow1 = .Range("a" & Rows.Count).End(3).Row+1

zhima

lenghonghai601 发表于 2018-7-10 10:20

谢谢回复。
表格内增加了项目后，运行代码显示“下标越界”，请问如何修改呢？