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

leoman0002

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

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



資料匯集.rar (16.67 KB)

下載次數: 7

2013-5-16 20:51

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

複製代碼

Hsieh

回復 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

複製代碼

leoman0002

這就是我想要的結果，學習到了....感謝