返回列表 上一主題 發帖

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

iverson105

帖子
27 
主題
11 
精華
0 
積分
38 
點名
0  
作業系統
window 
軟體版本
window7 
閱讀權限
10 
性別
男 
註冊時間
2019-12-12 
最後登錄
2021-4-21 
1# 跳轉到 »
發表於 2020-1-30 11:31 | 只看該作者

如何解?????執行階段錯誤"1004"



各位大大好

之前在此論壇上使用一個vba程式,可選取路經資料夾的檔案並使其自東複製後貼上指定的SHEET
但卻出現             執行階段錯誤"1004"   
                              找不到". 請檢查檔名是否有拼錯,或檔案位置是否正確.

程式如下
Sheets("工作表1").Activate

fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
If IsArray(fds) Then
For i = 1 To UBound(fds)
   [A2].Offset(i - 1) = fds(i)
Next
End If

Sheets("工作表1").Activate

For Each a In Range([A2], Cells(Rows.Count, 1).End(xlUp))
    With Workbooks.Open(a)...................................................這句出現ERROR
    .Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    .Close 0
  End With
  Next

Sheets("工作表1 (2)").Activate

Range("A2").Select
Columns("A:A").EntireColumn.AutoFit
Sheets("工作表1").Activate
   
End Sub

想麻煩各位大大看下,幫個忙嗎?
Ian

TOP

GBKEE

帖子
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-24 13:50 | 只看該作者
回復 1# iverson105
幫你修改一下會錯誤可能是先前遺留不是檔案的資料
加上程式碼清除先前遺留的檔案文字
  1. Option Explicit
  2. Sub Ex()
  3.     Dim fds, i As Integer
  4.     With Sheets("工作表1")
  5.         '**清除先前遺留的檔案文字****
  6.         .Range(.Range("a2"), .Range("a2").End(xlDown)) = ""
  7.         fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
  8.         If IsArray(fds) Then
  9.             For i = 1 To UBound(fds)
  10.                 .Range("A2").Cells(i) = fds(i)
  11.                 With Workbooks.Open(.Range("A2").Cells(i))
  12.                     .Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
  13.                     .Close 0
  14.                 End With
  15.             Next
  16.         End If
  17.     End With
  18. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

iverson105

帖子
27 
主題
11 
精華
0 
積分
38 
點名
0  
作業系統
window 
軟體版本
window7 
閱讀權限
10 
性別
男 
註冊時間
2019-12-12 
最後登錄
2021-4-21 
3# 倒序看帖
打印
tT
發表於 2020-4-24 13:50 | 只看該作者

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

請問各位大大
以下兩段程式碼是
1.開啟資料夾讀取所要的檔案路徑連結
2.把開啟的連結檔案打開 並將檔案內的sheet資料匯入
問題是當想要匯入的資料有很多sheet,想指定匯入某個sheet的某一欄位或某一列資料時,要怎麼改寫

謝謝各位指教阿
  1. Sub DATA_INPUT()

  3. fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
  4.                                 
  5. If IsArray(fds) Then
  6. For i = 1 To UBound(fds)
  7.    [A2].Offset(i - 1) = fds(i)
  8. Next
  9. End If

  11. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  12. On Error Resume Next  '''''' 錯誤跳過
  13. For Each a In Range([A2], Cells(Rows.Count, 1).End(xlUp))
  14.   With Workbooks.Open(a)
  15.       .Sheets.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
  16.      .Close 0
  17.   End With
  18. Next
  19. On Error GoTo 0 '''''''''''''錯誤跳過'''''''''''
  20. End Sub
複製代碼
收藏 分享
Ian

GBKEE

帖子
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-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

iverson105

帖子
27 
主題
11 
精華
0 
積分
38 
點名
0  
作業系統
window 
軟體版本
window7 
閱讀權限
10 
性別
男 
註冊時間
2019-12-12 
最後登錄
2021-4-21 
5#
發表於 2020-4-28 10:58 | 只看該作者
回復 4# GBKEE
請問一下
我想改寫的是

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

(把所有開啟的活頁簿上的某一工作表 中的(列如:Sheet("C").Range("A39:D99")自動複製到我指定的sheet(ie:"工作表2")的A1開始)
因為開啟的工作表可能有很多個(ie:sheet("C")/Sheet("C1") /Sheet("C2")....但每個sheet裡 我只要Range("A39:D99"),
可以改寫成   .Sheets.Range("A39:D99").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

TKS
Ian

TOP

iverson105

帖子
27 
主題
11 
精華
0 
積分
38 
點名
0  
作業系統
window 
軟體版本
window7 
閱讀權限
10 
性別
男 
註冊時間
2019-12-12 
最後登錄
2021-4-21 
6#
發表於 2020-4-28 11:00 | 只看該作者
回復 2# GBKEE

感激不盡
Ian

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2020-4-28 14:24 | 只看該作者
回復 6# iverson105

對你的說明沒有很明白
試試看下面程式碼對嗎!
  1. Option Explicit
  2. Sub Ex()
  3.     Dim fds, i As Integer, Rng As Range, XSh As Worksheet, Sh As Worksheet
  4.         fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
  5.         If IsArray(fds) Then
  6.             Set Rng = Sheets("工作表2").Cells(Rows.Count, "a").End(xlUp)  '   的sheet(ie:"工作表2")的A1開始
  7.             If Rng <> "" Then Set Rng = Rng.Offset(1)
  8.             For i = 1 To UBound(fds)
  9.                 With Workbooks.Open(fds(i))
  10.                     For Each Sh In .Sheets
  11.                     '  If InStr(Sh.Name, "XXX") Then  '可加上條件 有指定工作名稱
  12.                         Sh.[A39:D99].Copy Rng    '但每個sheet裡 我只要Range("A39:D99"),
  13.                         Set Rng = Sheets("工作表2").Cells(Rows.Count, "a").End(xlUp).Offset(1)
  14.                         Debug.Print Rng.Address
  15.                       'End If
  16.                     Next
  17.                     .Close 0
  18.                 End With
  19.            Next
  20.         End If
  21. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

iverson105

帖子
27 
主題
11 
精華
0 
積分
38 
點名
0  
作業系統
window 
軟體版本
window7 
閱讀權限
10 
性別
男 
註冊時間
2019-12-12 
最後登錄
2021-4-21 
8#
發表於 2020-4-29 13:51 | 只看該作者
回復 7# GBKEE


    請問大大
我有附上兩張圖片
1.是 錯誤訊息
2.是我的操作概念
不知道你這樣有沒有比較明白我的意思


感謝指教

Error1.png (151.29 KB)

Error1.png

Ian

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
9#
發表於 2020-4-29 16:42 | 只看該作者
回復 8# iverson105
  1. Option Explicit
  2. Sub Ex()
  3.     Dim fds, i As Integer, Rng As Range, x_Sh As Worksheet, Sh As Worksheet
  4.         fds = Application.GetOpenFilename("Excel Files (*.xlsm;*.xlsx), *.xlsm;*.xlsx", , , , True)
  5.         If IsArray(fds) Then
  6.             Set x_Sh = ThisWorkbook.Sheets("工作表2")   '你指定複製資料到的工作表
  7.             Set Rng = x_Sh.Cells(Rows.Count, "a").End(xlUp)  '
  8.             If Rng <> "" Then Set Rng = Rng.Offset(1)
  9.             For i = 1 To UBound(fds)
  10.                 With Workbooks.Open(fds(i))  '開啟指定的檔案
  11.                     For Each Sh In .Sheets
  12.                       If InStr(UCase(Sh.Name), "SHEETC") Then    '你所指定的工作表名稱"SHEETC"
  13.                          Sh.[A39:D99].Copy Rng                                      '**A39:D99 你要複製的範圍
  14.                         Set Rng = x_Sh.Cells(Rows.Count, "a").End(xlUp).Offset(1)
  15.                       End If
  16.                     Next
  17.                     .Close 0
  18.                 End With
  19.            Next
  20.         End If
  21. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

iverson105

帖子
27 
主題
11 
精華
0 
積分
38 
點名
0  
作業系統
window 
軟體版本
window7 
閱讀權限
10 
性別
男 
註冊時間
2019-12-12 
最後登錄
2021-4-21 
10#
發表於 2020-4-30 10:52 | 只看該作者
回復 9# GBKEE

謝謝!大大的幫助!
    感激不盡!
Ian

TOP

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
返回列表 上一主題