急!急!想請問寫出選擇性匯入資料的方法(已有一段程式碼,但不知道如何改寫))

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

1^# 跳轉到 »

發表於 2020-4-24 13:50 | 顯示全部帖子

回復 1# iverson105
幫你修改一下會錯誤可能是先前遺留不是檔案的資料
加上程式碼清除先前遺留的檔案文字

Option Explicit
Sub Ex()
Dim fds, i As Integer
With Sheets("工作表1")
'**清除先前遺留的檔案文字****
.Range(.Range("a2"), .Range("a2").End(xlDown)) = ""
fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
If IsArray(fds) Then
For i = 1 To UBound(fds)
.Range("A2").Cells(i) = fds(i)
With Workbooks.Open(.Range("A2").Cells(i))
.Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Close 0
End With
Next
End If
End With
End Sub

複製代碼

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

2^#

發表於 2020-4-26 14:23 | 顯示全部帖子

回復 3# iverson105
.Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
上式**為所開啟活頁簿上所有工作表複製到ThisWorkbook(執行巨集的活頁簿)下

你想改為想指定匯入某個sheet的某一欄位或某一列資料時
試試看
.Sheets(1).Rows(1).Copy ThisWorkbook.Sheets("工作表2").Rows(3)
**所開啟活頁簿第一個Sheet第一列(整列)複製到ThisWorkbook名稱"工作表2"Sheet上的第二列(整列)
.Sheets("工作表1").Range("b5:d6").Copy ThisWorkbook.Sheets("工作表2").Range("f5")
**所開啟活頁簿名稱"工作表1"Sheet上"b5:d6"複製到ThisWorkbook名稱"工作表2"Sheet上的"f5"

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

3^#

發表於 2020-4-28 14:24 | 顯示全部帖子

回復 6# iverson105

對你的說明沒有很明白
試試看下面程式碼對嗎!

Option Explicit
Sub Ex()
Dim fds, i As Integer, Rng As Range, XSh As Worksheet, Sh As Worksheet
fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
If IsArray(fds) Then
Set Rng = Sheets("工作表2").Cells(Rows.Count, "a").End(xlUp) ' 的sheet(ie:"工作表2")的A1開始
If Rng <> "" Then Set Rng = Rng.Offset(1)
For i = 1 To UBound(fds)
With Workbooks.Open(fds(i))
For Each Sh In .Sheets
' If InStr(Sh.Name, "XXX") Then '可加上條件有指定工作名稱
Sh.[A39:D99].Copy Rng '但每個sheet裡我只要Range("A39:D99"),
Set Rng = Sheets("工作表2").Cells(Rows.Count, "a").End(xlUp).Offset(1)
Debug.Print Rng.Address
'End If
Next
.Close 0
End With
Next
End If
End Sub

複製代碼

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

4^#

發表於 2020-4-29 16:42 | 顯示全部帖子

回復 8# iverson105

Option Explicit
Sub Ex()
Dim fds, i As Integer, Rng As Range, x_Sh As Worksheet, Sh As Worksheet
fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
If IsArray(fds) Then
Set x_Sh = ThisWorkbook.Sheets("工作表2") '你指定複製資料到的工作表
Set Rng = x_Sh.Cells(Rows.Count, "a").End(xlUp) '
If Rng <> "" Then Set Rng = Rng.Offset(1)
For i = 1 To UBound(fds)
With Workbooks.Open(fds(i)) '開啟指定的檔案
For Each Sh In .Sheets
If InStr(UCase(Sh.Name), "SHEETC") Then '你所指定的工作表名稱"SHEETC"
Sh.[A39:D99].Copy Rng '**A39:D99 你要複製的範圍
Set Rng = x_Sh.Cells(Rows.Count, "a").End(xlUp).Offset(1)
End If
Next
.Close 0
End With
Next
End If
End Sub

複製代碼

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

TOP

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]