標題:
[發問]
如何指定將不同檔案夾的csv檔中特定範圍的資料copy到特定檔案中
[打印本頁]
作者:
oak0723-1
時間:
2017-3-2 13:49
標題:
如何指定將不同檔案夾的csv檔中特定範圍的資料copy到特定檔案中
小弟有一個檔案夾名稱000(如附件)
該檔案夾000中有名稱分別為01.02.03等3個檔案夾
而於檔案夾01及02中分別有數個csv檔
另於檔案夾03中也有數個xls檔(如附件03-1)
想在檔案夾03中的xls中指定路徑和檔案名稱將資料copy到指定儲存格(如附件03檔案夾中之03-1檔案說明)
作者:
oak0723-1
時間:
2017-3-3 17:40
標題:
如何讀取多個檔案中同一個儲存格資料
各位先進好
請問如何讀取多個EXCEL檔案中同一個儲存格資料(如附件)
作者:
GBKEE
時間:
2017-3-4 14:31
回復
1#
oak0723-1
試試看
Option Explicit
Dim Wb As Workbook
Sub Ex()
Dim xFile As String, Sh As Worksheet, i As Integer, Rng As Range
Set Wb = Workbooks("03.XLS") '指定的XLS擋
xFile = ThisFile
If InStr(xFile, "CSV") = False Then MsgBox xFile: Exit Sub
Set Sh = Wb.Sheets("SHEET1") '指定的XLS擋的工作頁
With Workbooks.Open(xFile)
For i = 1 To 2
Set Rng = .Sheets(1).Range(Sh.Cells(1 + 1, "E") & ":" & Sh.Cells(1 + i, "F")) '指定的位置
Set Rng = .Sheets(1).Range(Rng, Rng.End(xlDown)) ''指定的位置往下至資料的終點
With Sh.Cells(Rows.Count, "a").End(xlUp).Offset(1) 'A欄最底列往上到有資料的儲存閣的下一列
.Resize(Rng.Rows.Count, Rng.Columns.Count) = Rng.Value
End With
Next
.Close
End With
End Sub
Function ThisFile() As String
With Wb '**指定的XLS擋
ThisFile = Mid(.Path, 1, InStrRev(.Path, "\")) '**指定的XLS擋的上層資料夾
With .Sheets("Sheet1")
ThisFile = ThisFile & .Range("b2") & "\" & .Range("c2") & ".CSV" '上層資料夾+子資料\的CSV檔案完整路徑
'**** 檢查CSV的檔案是否存在
If Dir(ThisFile) = "" Or Application.CountA(.Range("E2:F3")) <> 4 Then ThisFile = "請檢查" & vbLf & Join(Application.Transpose(Application.Transpose([B1:F1])), ",")
End With
End With
End Function
複製代碼
作者:
oak0723-1
時間:
2017-3-4 23:47
感謝GBKEE老師的賜教
只不過小弟發現2個問題
1.若輸入資料夾和檔名若非原預設01,01-1就無法執行
2.若輸入資料夾和檔名維持原預設01,01-1更改欄位起點和終點儲存格(例如輸入d5和f5)所copy過來的資料卻仍是原預設d1,f1
3.若檔案03更改名稱就無法執行出現錯誤
作者:
GBKEE
時間:
2017-3-5 05:43
回復
3#
oak0723-1
2#的程式碼是依你提出的條件所寫,你要改變條件當然會不行的
Set Wb = Workbooks("03.XLS") '指定的XLS擋
Set Wb = ActiveWindow '作用中的XLS擋
Set Wb = ThisWorkbook '程式碼所在的XLS擋
Set Wb = Windows(2) '第二個XLS擋
複製代碼
作者:
oak0723-1
時間:
2017-3-5 14:55
感謝GBKEE老師願意熱心繼續回復小弟的問題
可能我問題問得不好
因為小弟只是舉例
所以檔名都簡化替代
但實務上小弟的資料夾很多
每個檔案中的csv檔案也很多
當然每個檔名也都不同
因為每個csv檔內都有2組資料須cpy集中在同一個xls檔內
所以希望有熱心網友能幫幫小弟的忙
謝謝
作者:
oak0723-1
時間:
2017-3-8 21:50
感謝GBKEE老師願意熱心繼續關心小弟的問題
小弟這個問題已用其他方式解決
不知是否能幫小弟另一個問題
如何讀取多個檔案中同一個儲存格資料
http://forum.twbts.com/thread-19358-1-1.html
作者:
GBKEE
時間:
2017-3-9 08:57
回復
7#
oak0723-1
Option Explicit
Sub Ex()
Dim Rng(1 To 2) As Range, Sh As Worksheet, i As Integer, E As Range
'**設定讀取多檔案的資料位置
Set Rng(1) = ActiveWorkbook.ActiveSheet.Range("C7") '**視窗作用中的活頁簿的作用中工作頁的"C7"
'Set Rng(1) = WorkbookS("???.xls").Sheets("???").Range("C7") '**指定的活頁簿的???工作頁的"C7"
'Set Rng(1) = ThisWorkbook.Sheets("???").Range("C7") '**程式碼所在的活頁簿的???工作頁的"C7"
'**設定 F6等黃色區域輸入儲存格編號的位置
Set Rng(2) = Rng(1).Parent.Range("F6")
Set Rng(2) = Range(Rng(2), Rng(2).End(xlToRight)) '延伸到最右邊的資料
'**************************************
Do While Rng(1) <> "" 'Rng有資料
If Dir(Rng(1) & "\" & Rng(1).Cells(1, 2) & ".xls") = "" Then GoTo NoXls_Or_NoSheet:
With Workbooks.Open(Rng(1) & "\" & Rng(1).Cells(1, 2) & ".xls") '**開啟多檔案 (XLS或 CSV)
On Error GoTo NoXls_Or_NoSheet:
Set Sh = .Sheets(Rng(1).Cells(1, 3).Text) '**設定多檔案的工作頁
Err.Clear
i = 4
For Each E In Rng(2)
Rng(1).Cells(1, i) = Sh.Range(E) '讀取黃色區域指定的資料
i = i + 1
Next
.Close '關閉檔案
End With
Set Rng(1) = Rng(1).Offset(1) '下一個檔案資料
Loop
'*********************************************
Exit Sub '程式執行正常下離開這程式
NoXls_Or_NoSheet:
MsgBox Rng(1) & " \ " & Rng(1).Cells(1, 2) & " \ " & Rng(1).Cells(1, 3) & vbLf & "找不到" & IIf(Err, Rng(1).Cells(1, 3).Text, "")
End Sub
複製代碼
作者:
oak0723-1
時間:
2017-3-12 22:28
感謝GBKEE老師願意熱心幫小弟解答的問題
因小弟最近比較忙加上有點感冒..所以精神較差
所以比較晚回復..真是抱歉....
剛測試過..確實是小弟所需要的
非常感謝...
再次感恩...
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
