Board logo

標題: [發問] 關於跳行的問題 [打印本頁]
作者: starbox520    時間: 2017-1-19 18:56     標題: 關於跳行的問題

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

使用方法是: 開啟"匯出"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
複製代碼
應該要這樣呈現
[attach]26420[/attach]
而不是一直在同一行呈現...(當然最後只有最後找到的一筆的結果)
[attach]26421[/attach]

我寫入的地方在這裡
  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
複製代碼
[attach]26422[/attach]
作者: c_c_lai    時間: 2017-1-19 20:24

回復 1# starbox520
  1. Option Explicit

  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    時間: 2017-1-19 21:46

回復 2# c_c_lai


    謝謝C大分析
   
    懂了XD



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)