|

樓主 |
發表於 2013-11-20 18:53:35
|
顯示全部樓層
- Private Sub cmdClearData_Click()
- Sheet1.Range("A5:B65535").Clear '將舊的A-B欄資料清除
- End Sub
- Private Sub cmdMerge_Click()
- Dim objsheet As Worksheet
-
-
- WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
-
-
- Excel.Workbooks.Add '開新的workbook
-
- desc = Excel.ActiveWorkbook.Name '新檔案視窗編號
-
-
- i = 5
- While Windows(WorkName).ActiveSheet.Range("b" & i) <> ""
-
-
- Filename = Windows(WorkName).ActiveSheet.Range("b" & i)
-
- n = InStr(1, Filename, ".")
-
- strFileName = Left(Filename, n - 1) '檔案名稱
- strsFileType = Mid(Filename, n + 1) '檔案類型
-
-
-
- If Windows(WorkName).ActiveSheet.Range("a" & i) = "" Then
- Fullpath = Excel.Workbooks(WorkName).Path & "" & Filename
- Else
- Fullpath = Windows(WorkName).ActiveSheet.Range("a" & i) & Filename
- End If
-
- '檢查檔案是否存在
- If Dir(Fullpath) = "" Then
- MsgBox "檔案:" & Fullpath & "不存在,請查看是否有拼錯字"
- Exit Sub '離開程式
- Else
- Workbooks.Open Filename:=Fullpath
- End If
-
-
- If UCase(strsFileType) = "XLS" Then
- Workbooks.Open Filename:=Fullpath '開啟檔案
- Else
- If UCase(Windows(WorkName).ActiveSheet.Range("b1")) = "N" Then
- Workbooks.OpenText Filename:=Fullpath, Origin:=Windows(WorkName).ActiveSheet.Range("b2"), _
- StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
- ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
- , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
- TrailingMinusNumbers:=True
- Else
- Workbooks.OpenText Filename:=Fullpath, Origin:=Windows(WorkName).ActiveSheet.Range("b2"), _
- DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
- ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
- Space:=True
- End If
- End If
-
- sheetname = Windows(WorkName).ActiveSheet.Range("b3")
-
- If sheetname <> "" Then
-
- '檢查活頁是否存在
- flag = 0
- For j = 1 To Windows(Filename).Parent.Sheets.Count
- If Windows(Filename).Parent.Sheets(j).Name = sheetname Then
- flag = 1
- Exit For
- End If
- Next
-
- If flag = 1 Then
- Windows(Filename).Parent.Sheets(sheetname).Select '切換活頁
- End If
-
- End If
- Set objsheet = Windows(Filename).ActiveSheet '切換視窗
-
- '選取來源範圍
- objsheet.Cells.Select
- 'copy
- Selection.Copy
-
- Windows(desc).Activate '切換視窗
-
- Sheets.Add after:=Worksheets(Worksheets.Count) '增加活頁
- ActiveSheet.Paste '貼上
- ActiveSheet.Range("A1").Select '將選取範圍取消
-
- ActiveSheet.Name = strFileName '將活頁名稱改成檔案名稱
- '避免copy太多資料時,要關閉檔案時.會問記憶體的資料是否要保留
- ActiveSheet.Range("A1").Copy
-
- '將來源檔案關閉
- Windows(Filename).Close
-
- i = i + 1 '讀取下一個檔案名稱
- Wend
- MsgBox "已將所有檔案匯入活頁中", , "彰化一整天的Blog http://272586.blogspot.com"
- End Sub
- Private Sub cmdSelectFile_Click()
- Dim fd As FileDialog '宣告一個檔案對話框
-
- Set fd = Excel.Application.FileDialog(msoFileDialogFilePicker) '設定選取檔案功能
-
-
- fd.Filters.Clear '清除之前的資料
-
- fd.Filters.Add "Excel File", "*.xls*" '設定顯示的副檔名
- fd.Filters.Add "Word File", "*.txt"
- fd.Filters.Add "Word File", "*.csv"
- fd.Filters.Add "所有檔案", "*.*"
-
- fd.Show '顯示對話框
-
- str_row = Range("b1").End(xlDown).Row '開始列前一筆(最後一筆非空白資料的列數)
-
-
-
- For i = 1 To fd.SelectedItems.Count
- strFullName = fd.SelectedItems(i)
-
-
- n = rinstr(strFullName, "")
-
- strFileNameType = Mid(strFullName, n + 1)
-
- strFullPath = Left(strFullName, n)
- Sheet1.Cells(i + str_row, 1) = strFullPath '顯示所選取的檔案路徑
-
- n = InStr(1, strFileNameType, ".")
-
- strFileName = Left(strFileNameType, n - 1)
- strsFileType = Mid(strFileNameType, n + 1)
-
- Sheet1.Cells(i + str_row, 2) = strFileNameType
-
- Next
- End Sub
- Function rinstr(ByVal t As String, ByVal s As String)
- '自訂函數找尋某個字串最後出現的位置
- Dim i As Integer
- Dim n As Integer
-
- n = 0
- For i = 1 To Len(t)
- If Mid(t, i, 1) = s Then
- n = i
- End If
- Next
- rinstr = n
- End Function
複製代碼 |
|