[已解决]表1,导入表2数据错误

rewfs521

想从表2将数据导入表1,建立了一个循环,但只能导入最后一列数据,请指点!
表格.rar (8.77 KB, 下载次数: 8)

2012-9-7 21:57 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

5201314

2012-9-7 22:23

1. Sub test()
   
2. Dim LastRow As Integer, i As Integer,arr,brr,k as Integer
   
3. Application.ScreenUpdating = False '关闭屏幕刷新
   
4. Application.DisplayAlerts = False
   
5. Set Ws = Workbooks.Open(ThisWorkbook.Path & "\表2.xls") '打开工件簿文件
   
6. arr = Ws.Sheets("sheet1").UsedRange.Value
   
7. ReDim brr(1 To UBound(arr), 1 To 3)
   
8. Ws.Close (False) '关闭工作簿，不保存
   
9. For i = 2 To UBound(arr)
   
10. If arr(i, 3) <> 0 Then
    
11. k = k + 1
    
12. brr(k, 1) = arr(i, 1)
    
13. brr(k, 2) = arr(i, 2)
    
14. brr(k, 3) = arr(i, 3)
    
15. End If
    
16. Next
    
17. LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    
18. Sheets("Sheet1").Range("A" & LastRow).Resize(k, 3) = brr
    
19. Application.ScreenUpdating = rue
    
20. Application.DisplayAlerts = True
    
21. End Sub

复制代码

跳转到最佳答案楼层

lisachen

Sub Opiona()
    Dim z As Integer
    Dim x As Integer
    On Error Resume Next
    Application.ScreenUpdating = False    '关闭屏幕刷新
    Application.DisplayAlerts = False
    Set xlbook = Workbooks.Open(ThisWorkbook.Path & "\表2.xls")    '打开工件簿文件
    Set sh = xlbook.Sheets("sheet1")
    z = ThisWorkbook.Sheets("sheet1").Range("a65536").End(xlUp).Row
    'z = z + 1这一句放错了位置
    For x = 2 To 20
        If sh.Cells(x, 3) <> 0 Then
            z = z + 1
            Cells(z, 1) = sh.Cells(x, 1)
            Cells(z, 2) = sh.Cells(x, 2)
            Cells(z, 3) = sh.Cells(x, 3)
        End If
    Next
    Windows(ThisWorkbook.Name).Activate    '回到操作主表界面
    xlbook.Close (False)   '关闭工作簿，不保存
    Application.ScreenUpdating = rue
    Application.DisplayAlerts = True
End Sub

5201314

1. Sub test()
   
2. Dim LastRow As Integer, i As Integer,arr,brr,k as Integer
   
3. Application.ScreenUpdating = False '关闭屏幕刷新
   
4. Application.DisplayAlerts = False
   
5. Set Ws = Workbooks.Open(ThisWorkbook.Path & "\表2.xls") '打开工件簿文件
   
6. arr = Ws.Sheets("sheet1").UsedRange.Value
   
7. ReDim brr(1 To UBound(arr), 1 To 3)
   
8. Ws.Close (False) '关闭工作簿，不保存
   
9. For i = 2 To UBound(arr)
   
10. If arr(i, 3) <> 0 Then
    
11. k = k + 1
    
12. brr(k, 1) = arr(i, 1)
    
13. brr(k, 2) = arr(i, 2)
    
14. brr(k, 3) = arr(i, 3)
    
15. End If
    
16. Next
    
17. LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    
18. Sheets("Sheet1").Range("A" & LastRow).Resize(k, 3) = brr
    
19. Application.ScreenUpdating = rue
    
20. Application.DisplayAlerts = True
    
21. End Sub

复制代码

rewfs521

lisachen 发表于 2012-9-7 22:10
Sub Opiona()
    Dim z As Integer
    Dim x As Integer

刚才代码有空格!  呵呵  感谢!

lisachen

rewfs521 发表于 2012-9-7 22:29
刚才代码有空格!  呵呵  感谢!

可能是系统的问题，，红色部分是我认为有问题及修改的地方。没动你的其他语句，代码可以执行

hhl1984

奇怪，你要求的跟答案好像有点不符啊，我也只是在学习