請問做法 ?A檔案有10000筆資料，要輸出成5個新檔A1~A5，每個檔案2000筆資料 excel, vba

storybear

目前的狀況是，5個檔案都建立了，可是只有第A1有2000筆資料，A2~A5都是空白的，請大師看一下那裏有問題?

1. Private Sub rutenexport() '匯出上架檔 -露天
   
2. 
   
3. Dim sb, db As Workbook
   
4. 
   
5. 'wp = ActiveWorkbook.Path & "\" '指定存檔位置
   
6. wp = ActiveWorkbook.Path & "\" & "ruten" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & "-" & Hour(Time) & "-" & Minute(Time) & "-" & Second(Time) & "\" '指定存檔位置
   
7. 
   
8. If Len(Dir(wp, vbDirectory)) = 0 Then
   
9.    
   
10.    MkDir wp
    
11.    
    
12. End If
    
13. 
    
14. 
    
15. Set sb = Workbooks("上架資料轉換.xlsx")
    
16. 
    
17. sb.Sheets("露天上架檔").Range("AE:XX").Delete
    
18. 
    
19. 'sb.Sheets("露天上架檔").Range("A:A").Delete '刪除第1行編號
    
20. 
    
21. '================每個檔案2000筆資料匯出A
    
22. For i = 1 To 5
    
23. 
    
24. db1 = "ruten_auction2014-" & i & ".xls"
    
25. 
    
26. Set NewBook = Workbooks.Add
    
27. 
    
28.     With NewBook
    
29.         .Title = "All Sales"
    
30.         
    
31.         .Subject = "Sales"
    
32.         
    
33.         .SaveAs Filename:=wp & db1
    
34.         
    
35.     End With
    
36.    
    
37. Set db = Workbooks(db1)
    
38.    
    
39. pt = i * 2000
    
40. 
    
41. MsgBox db.Name
    
42. 
    
43. sb.Sheets("露天上架檔").Range(Cells(pt - 1999, 1), Cells(pt, 31)).Copy Workbooks(db1).Sheets("sheet1").Range(Cells(pt - 1999, 1), Cells(pt, 31))
    
44. 
    
45. 'db.Close
    
46. 
    
47. Next i
    
48. 
    
49. MsgBox "露天上架檔已匯出"
    
50. End Sub

複製代碼

空白的樂章

這兩句語法有點問題
sb.Sheets("露天上架檔").Range(Cells(pt - 1999, 1), Cells(pt, 31)).Copy
Workbooks(db1).Sheets("sheet1").Range(Cells(pt - 1999, 1), Cells(pt, 31))

你仔細再看一下檔案，應該A2~A5不是沒資料
而是A2的資料貼到2001~4000列
A3貼到4001~6000列以此列推了
第二句程式碼應該固定儲存格就好
可以改成
Workbooks(db1).Sheets("sheet1").Range("A1").select
activate.paste
意思就是在A1欄位貼上複製的儲存格內容