返回列表 上一主題 發帖

[發問] 請教如何將選擇檔案(原本只能選一個，想改成一次選多個)

leoman0002

帖子
29 
主題
3 
精華
0 
積分
39 
點名
0  
作業系統
WINDOWS XP 
軟體版本
office 2003 
閱讀權限
10 
性別
男 
來自
台灣 
註冊時間
2012-10-12 
最後登錄
2020-10-15 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2013-5-16 20:54 | 只看該作者

[發問] 請教如何將選擇檔案(原本只能選一個，想改成一次選多個)

原先是使用
fd = ThisWorkbook.Path & "\"
fs = Dir(fd & "*.csv")

但是常常有需要臨時匯入的情況，後來修改之後...變成一次只能匯入一個檔案，
想情教各位老師!! 我應該要修改哪裡 ^^  



資料匯集.rar (16.67 KB)
  1. Sub ex()
  2.    Dim arr()
  3.   Dim Filename As Variant
  4.   Dim i As Integer
  5.   fs = Application.GetOpenFilename("僅能匯入csv格式,*.csv", , "確定", , False)
  6.   p = Range("G65536").End(xlUp).Row + 1
  7.   With CreateObject("Microsoft.XMLHTTP")
  8.   .Open "GET", fs, False
  9.   .Send
  10.   tt = .responsetext
  11.   ss = Split(tt, vbCrLf)
  12.   End With
  13.   ReDim arr(0 To UBound(ss), 0 To 15)
  14.   For i = 0 To UBound(ss)
  15.   s1 = Split(ss(i), ",")
  16.   For j = 0 To UBound(s1)
  17.     arr(i, j) = s1(j)
  18.   Next j
  19.   Next i
  20.   Cells(p, "a") = Replace(arr(5, 1), "'", "")
  21.   Cells(p, "b") = Replace(Split(Cells(p, "a"), "-")(0), Mid(Split(Cells(p, "a"), "-")(0), 3, 5), "")
  22.   Cells(p, "c") = Split(Cells(p, "a"), "-")(1)
  23.   Cells(p, "G") = arr(3, 3)
  24.   If arr(11, 7) = "Bef" Then
  25.   Cells(p, "H") = "[Before]"
  26.   Else
  27.   Cells(p, "H") = "[After]"
  28.   End If
  29.   Cells(p, "I") = arr(11, 5)
  30.   Cells(p, "J") = arr(11, 5)
  31.   Cells(p, "K") = arr(20, 5)
  32.   Cells(p, "R") = arr(21, 5)
  33.   Cells(p, "S") = arr(22, 5)
  34.   Cells(p, "T") = arr(23, 5)
  35.   k = 20
  36.   For i = 26 To 33
  37.   For j = 1 To 3
  38.     k = k + 1
  39.     Cells(p, k) = arr(i, (j - 1) * 2 + 1)
  40.   Next j
  41.   Next i
  42. End Sub
複製代碼
收藏 分享
好可愛的寶寶

leoman0002

帖子
29 
主題
3 
精華
0 
積分
39 
點名
0  
作業系統
WINDOWS XP 
軟體版本
office 2003 
閱讀權限
10 
性別
男 
來自
台灣 
註冊時間
2012-10-12 
最後登錄
2020-10-15 
3#
發表於 2013-5-17 00:08 | 只看該作者
這就是我想要的結果，學習到了....感謝
好可愛的寶寶

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2013-5-16 22:17 | 只看該作者
回復 1# leoman0002
  1. Sub ex()
  2.    Dim arr()
  3.   Dim Filename As Variant
  4.   Dim i As Integer
  5.   fs = Application.GetOpenFilename("僅能匯入csv格式,*.csv", , "ワ確定", , True)  '改成複選檔案
  6.   For Each f In fs '每個檔案迴圈
  7.   p = Range("G65536").End(xlUp).Row + 1
  8.   With CreateObject("Microsoft.XMLHTTP")
  9.   .Open "GET", f, False
  10.   .Send
  11.   tt = .responsetext
  12.   ss = Split(tt, vbCrLf)
  13.   End With
  14.   ReDim arr(0 To UBound(ss), 0 To 15)
  15.   For i = 0 To UBound(ss)
  16.   s1 = Split(ss(i), ",")
  17.   For j = 0 To UBound(s1)
  18.     arr(i, j) = s1(j)
  19.   Next j
  20.   Next i
  21.   Cells(p, "a") = Replace(arr(5, 1), "'", "")
  22.   Cells(p, "b") = Replace(Split(Cells(p, "a"), "-")(0), Mid(Split(Cells(p, "a"), "-")(0), 3, 5), "")
  23.   Cells(p, "c") = Split(Cells(p, "a"), "-")(1)
  24.   Cells(p, "G") = arr(3, 3)
  25.   If arr(11, 7) = "Bef" Then
  26.   Cells(p, "H") = "[Before]"
  27.   Else
  28.   Cells(p, "H") = "[After]"
  29.   End If
  30.   Cells(p, "I") = arr(11, 5)
  31.   Cells(p, "J") = arr(11, 5)
  32.   Cells(p, "K") = arr(20, 5)
  33.   Cells(p, "R") = arr(21, 5)
  34.   Cells(p, "S") = arr(22, 5)
  35.   Cells(p, "T") = arr(23, 5)
  36.   k = 20
  37.   For i = 26 To 33
  38.   For j = 1 To 3
  39.     k = k + 1
  40.     Cells(p, k) = arr(i, (j - 1) * 2 + 1)
  41.   Next j
  42.   Next i
  43.   Next f
  44. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 太陽光大、父母恩大、君子量大，小人氣大。
返回列表 上一主題