返回列表 上一主題 發帖

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

starbox520

帖子
192 
主題
15 
精華
0 
積分
194 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
女 
註冊時間
2016-9-22 
最後登錄
2020-8-28 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2016-12-19 09:59 | 只看該作者

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

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

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

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

分別取第8欄跟第19欄

附檔有1個月的資料

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

我只有取14天的資料

請問該如何做呢

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




tt1900.zip (589.85 KB)
收藏 分享

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
257  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-27 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2016-12-19 16:36 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

starbox520

帖子
192 
主題
15 
精華
0 
積分
194 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
女 
註冊時間
2016-9-22 
最後登錄
2020-8-28 

論壇榮譽勳章論壇贊助勳章
3#
發表於 2016-12-19 21:59 | 只看該作者
回復 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

  13. p = ThisWorkbook.Path & "\rawdata\"
  14. f = Dir(p & "*.xls")

  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
複製代碼

TOP

        靜思自在 : 能付出愛心就是福，能消除煩惱就是慧。
返回列表 上一主題