如何指定將不同檔案夾的csv檔中特定範圍的資料copy到特定檔案中 - Excel程式區

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2017-3-5 05:43 | 顯示全部帖子

回復 3# oak0723-1
2#的程式碼是依你提出的條件所寫,你要改變條件當然會不行的

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

[發問] 如何指定將不同檔案夾的csv檔中特定範圍的資料copy到特定檔案中