[發問] 如何從資料夾的Excel讀檔寫檔

starbox520

資料夾裡每日都會新增今日的數據
分別為第8欄跟第19欄

如果我得資料夾路徑是C:\Users\Rawdata

要把資料夾內的檔案全部跑一遍

分別取第8欄跟第19欄

附檔有1個月的資料

也有附上我合併起來的格式<跑完的結果>

我只有取14天的資料

請問該如何做呢

因為我有一年的資料要跑= " =

下載 (65.39 KB)

2016-12-19 09:58

tt1900.zip (589.85 KB)

下載次數: 11

2016-12-19 09:59

starbox520

回復 2# Hsieh
回版大
我是用這種方法可是有侷限在還要創資料夾
還是您的好用哈哈

1. Sub test()
   
2.     Range("B2").Select
   
3.     ActiveWindow.FreezePanes = True
   
4.    
   
5. Dim p, f, arr1, arr2, arr3, arr4,  dic
   
6. Application.ScreenUpdating = False
   
7. Set dic = CreateObject("scripting.dictionary")
   
8. ActiveSheet.Range("B2:AO65535").ClearContents
   
9.     For j = 2 To ActiveSheet.Range("A1").CurrentRegion.Rows.Count
   
10.         dic(Cells(j, 1).Value) = j
    
11.     Next
    
12. 
    
13. p = ThisWorkbook.Path & "\rawdata\"
    
14. f = Dir(p & "*.xls")
    
15. 
    
16. Do While Len(f)
    
17.     If f <> "" Then
    
18.         With GetObject(p & f)
    
19.             arr1 = .Sheets(2).Range("A2:A8")
    
20.             arr2 = .Sheets(2).Range("B2:U8")
    
21.             arr3 = .Sheets(2).Range("A13:A19")
    
22.             arr4 = .Sheets(2).Range("B13:U19")
    
23.             .Close SaveChanges:=False
    
24.         End With
    
25.     End If
    
26.     With ThisWorkbook.ActiveSheet
    
27.         For i = 1 To 7
    
28.             If dic(arr1(i, 1)) <> "" Then
    
29.                 .Range("B" & dic(arr1(i, 1))).Resize(1, UBound(arr2, 2)).Value = WorksheetFunction.Index(arr2, i, 0)
    
30.                 'h1 = dic(arr2(i, 1))
    
31.             
    
32.             End If
    
33.             If dic(arr3(i, 1)) <> "" Then
    
34.                 .Range("v" & dic(arr3(i, 1))).Resize(1, UBound(arr4, 2)).Value = WorksheetFunction.Index(arr4, i, 0)
    
35.             End If
    
36.         Next
    
37.     End With
    
38.     f = Dir
    
39. Loop
    
40. Application.ScreenUpdating = True
    
41. End Sub

複製代碼

Hsieh

回復 1# starbox520

1. Sub inputraw()
   
2. ActiveSheet.UsedRange.Offset(1).ClearContents
   
3. Application.ScreenUpdating = False
   
4. fd = "C:\Users\Rawdata\" 'rawdata檔案路徑
   
5. fs = Dir(fd & "*")
   
6. r = 2
   
7. Do Until fs = ""
   
8. With Workbooks.Open(fd & fs)
   
9.    ActiveSheet.Cells(r, 1).Resize(, 21) = .ActiveSheet.Cells(8, 1).Resize(, 21).Value
   
10.    ActiveSheet.Cells(r, 22).Resize(, 20) = .ActiveSheet.Cells(19, 2).Resize(, 20).Value
    
11.    .Close 0
    
12. End With
    
13. fs = Dir
    
14. r = r + 1
    
15. Loop
    
16. Application.ScreenUpdating = True
    
17. End Sub

複製代碼