[發問] 關於跳行的問題

starbox520

請問以下這組程式碼
為何我修改之後一直寫在同一行，不會往下一行寫入了

使用方法是: 開啟"匯出"Excel  -> 裡面點選按鈕"匯出"
就會執行裡面的VBA了
VBA會去找叫Rawdata的資料夾->裡面的EXCEL分別打開->取裡面我要的欄位資料 ->一直到最後一個EXCEL

1. Sub TT()
   
2. Dim Mypa$, workName$, brr(1), rr, br
   
3. Const sWm As String = "\Rawdata\"
   
4. t = Timer
   
5. Mypa = ThisWorkbook.Path & sWm
   
6. workName = Dir(Mypa & "*.xls")
   
7. Sheet1.UsedRange.Offset(1).ClearContents
   
8. Application.ScreenUpdating = False
   
9. Do Until workName = ""
   
10.     With GetObject(Mypa & workName)
    
11.         n = n + 1
    
12.         With .Sheets("Data")
    
13.             brr(0) = .Range("a8").Resize(1, 21)
    
14.             brr(1) = .Range("b19").Resize(1, 20)
    
15.         End With
    
16.         .Close False
    
17.     End With
    
18.     rr = brr(0): br = brr(1)
    
19.     With Sheet1
    
20.          i = .Cells(Rows.Count, 1).End(3).Row + 1
    
21.         .Range("c" & i).Resize(1, 21) = rr
    
22.         .Range("x" & i).Resize(1, 20) = br
    
23.     End With
    
24.     Erase brr()
    
25.     workName = Dir
    
26. Loop
    
27. Application.ScreenUpdating = True
    
28. MsgBox "共花" & Format(Timer - t, "0.000") & "秒" _
    
29.     & Chr(10) & "找到 " & n & "筆資料", vbOKCancel + vbInformation
    
30. End Sub

複製代碼

應該要這樣呈現

下載 (2.19 KB)

2017-1-19 18:49

而不是一直在同一行呈現...(當然最後只有最後找到的一筆的結果)

下載 (14.11 KB)

2017-1-19 18:49

我寫入的地方在這裡

1. With Sheet1
   
2.          i = .Cells(Rows.Count, 1).End(3).Row + 1
   
3.         .Range("c" & i).Resize(1, 21) = rr
   
4.         .Range("x" & i).Resize(1, 20) = br
   
5.     End With

複製代碼

TEST.rar (155.66 KB)

下載次數: 7

2017-1-19 18:56

c_c_lai

回復 1# starbox520

1. Option Explicit
   
2. 
   
3. Sub TT()
   
4.     Dim Mypa$, workName$, brr(1), pos As Long
   
5.     Dim t As Date, n As Long
   
6.    
   
7.     Const sWm As String = "\Rawdata\"
   
8.     t = Timer
   
9.     n = 0
   
10.     Mypa = ThisWorkbook.Path & sWm
    
11.     workName = Dir(Mypa & "*.xls")
    
12.     Sheet1.UsedRange.Offset(1).ClearContents
    
13.    
    
14.     Application.ScreenUpdating = False
    
15.     Do Until workName = ""
    
16.         'With GetObject(Mypa & workName)
    
17.         With Workbooks.Open(Mypa & workName)
    
18.             n = n + 1
    
19.             With .Sheets("Data")
    
20.                 brr(0) = .Range("a8").Resize(1, 21)
    
21.                 brr(1) = .Range("b19").Resize(1, 20)
    
22.             End With
    
23.             .Close False
    
24.         End With
    
25.         
    
26.         With Sheet1
    
27.             pos = .Cells(Rows.Count, 3).End(3).Row + 1
    
28.             .Range("c" & pos).Resize(1, 21) = brr(0)
    
29.             .Range("x" & pos).Resize(1, 20) = brr(1)
    
30.         End With
    
31.         Erase brr()
    
32.         workName = Dir
    
33.     Loop
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "共花" & Format(Timer - t, "0.000") & "秒" _
    
36.             & Chr(10) & "找到 " & n & "筆資料", vbOKCancel + vbInformation
    
37. End Sub

複製代碼

starbox520

回復 2# c_c_lai


    謝謝C大分析
   
    懂了XD