|

樓主 |
發表於 2013-9-13 13:43:09
|
顯示全部樓層
2013-09-13程式碼:
- Private Sub cmdMerge_Click()
- Dim a, b, c As Double '宣告a,b,c為倍精度整數
-
- Dim objsheet As Worksheet
-
- Dim objtarget As Worksheet
-
- Source = Excel.ActiveWorkbook.Name '新檔案視窗編號
-
- FilenameExt = Range("b1") '要處理的檔案副檔名
-
- Filename = Range("b2") '要處理的檔案名稱
-
- istxtFile = UCase(Range("b7")) '是否存為文字檔
-
- b = Range("b3").Value
-
- first_name = Range("b4").Value
- last_name = Range("b5").Value
-
-
-
- Workbooks.Open Filename:=Excel.Workbooks(Source).Path & "" & Filename & "." & FilenameExt
-
- WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
-
-
-
- '選取工作名稱
- Set objsheet = Windows(WorkName).ActiveSheet
-
-
- y = 1 '讀取欄位長度
-
- Do While True
- kk = ""
- For l = 1 To 10
- For k = 1 To 30
- If IsError(objsheet.Cells(k, y + l)) = False Then
- kk = kk & objsheet.Cells(k, y + l)
- End If
- Next
- Next l
- If kk = "" Then Exit Do
- y = y + 1
- Loop
-
-
- '選取目的
-
- Windows(WorkName).Activate
-
- start_x = Range("b6").Value '資料開始列數
-
- j = start_x
- a = j
- oldCell = objsheet.Cells(j, b)
- While oldCell <> ""
- If objsheet.Cells(j, b) <> oldCell Then
- Workbooks.Add '開新檔
- NewFile = Excel.ActiveWorkbook.Name '記住新檔案名稱
- '選取工作名稱
- Set objtarget = Windows(NewFile).ActiveSheet
- '選取來源範圍
- Windows(WorkName).Activate
- objsheet.Range(objsheet.Cells(1, 1), objsheet.Cells(start_x - 1, y)).Select 'copy標題
- Selection.Copy
- 'copy
- Windows(NewFile).Activate
- objtarget.Cells(1, 1).Select
- ActiveSheet.Paste
-
- Windows(WorkName).Activate
-
- objsheet.Range(objsheet.Cells(a, 1), objsheet.Cells(j - 1, y)).Select
- Selection.Copy
- Windows(NewFile).Activate
- objtarget.Cells(start_x, 1).Select
- ActiveSheet.Paste
- objtarget.Cells(1, 1).Select
-
- If istxtFile <> "Y" Then
- '對齊原本欄位
- For i = 1 To y
- objtarget.Cells(1, i).ColumnWidth = objsheet.Cells(1, i).ColumnWidth
- Next
-
- '對齊原本到列高
- '標題列
- For i = 1 To start_x - 1
- objtarget.Cells(i, 1).RowHeight = objsheet.Cells(i, 1).RowHeight
- Next
- '資料列
- For i = 1 To j - a
- objtarget.Cells(start_x - 1 + i, 1).RowHeight = objsheet.Cells(a + i - 1, 1).RowHeight
- Next
-
- '跟原本頁面設定一樣
-
- objtarget.PageSetup.LeftHeader = objsheet.PageSetup.LeftHeader
- objtarget.PageSetup.CenterHeader = objsheet.PageSetup.CenterHeader
- objtarget.PageSetup.RightHeader = objsheet.PageSetup.RightHeader
- objtarget.PageSetup.LeftFooter = objsheet.PageSetup.LeftFooter
- objtarget.PageSetup.CenterFooter = objsheet.PageSetup.CenterFooter
- objtarget.PageSetup.RightFooter = objsheet.PageSetup.RightFooter
- objtarget.PageSetup.LeftMargin = objsheet.PageSetup.LeftMargin
- objtarget.PageSetup.RightMargin = objsheet.PageSetup.RightMargin
- objtarget.PageSetup.TopMargin = objsheet.PageSetup.TopMargin
- objtarget.PageSetup.BottomMargin = objsheet.PageSetup.BottomMargin
- objtarget.PageSetup.HeaderMargin = objsheet.PageSetup.HeaderMargin
- objtarget.PageSetup.FooterMargin = objsheet.PageSetup.FooterMargin
- objtarget.PageSetup.PrintHeadings = objsheet.PageSetup.PrintHeadings
- objtarget.PageSetup.PrintGridlines = objsheet.PageSetup.PrintGridlines
- objtarget.PageSetup.PrintComments = objsheet.PageSetup.PrintComments
- objtarget.PageSetup.CenterHorizontally = objsheet.PageSetup.CenterHorizontally
- objtarget.PageSetup.CenterVertically = objsheet.PageSetup.CenterVertically
- objtarget.PageSetup.Orientation = objsheet.PageSetup.Orientation
- objtarget.PageSetup.Draft = objsheet.PageSetup.Draft
- objtarget.PageSetup.PaperSize = objsheet.PageSetup.PaperSize
- objtarget.PageSetup.FirstPageNumber = objsheet.PageSetup.FirstPageNumber
- objtarget.PageSetup.Order = objsheet.PageSetup.Order
- objtarget.PageSetup.BlackAndWhite = objsheet.PageSetup.BlackAndWhite
- objtarget.PageSetup.Zoom = objsheet.PageSetup.Zoom
- objtarget.PageSetup.PrintErrors = objsheet.PageSetup.PrintErrors
- End If
-
- a = j
-
-
- '將活頁改成跟檔案名稱同名
- objtarget.Name = replace_string(Trim(oldCell))
-
- '先檢查檔案是否存在
- Set fs = CreateObject("Scripting.FileSystemObject")
-
-
- While (fs.FileExists(Excel.Workbooks(Source).Path & "" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt))
-
- oldCell = InputBox("檔案重覆,請輸入其它名稱,若輸入*代表離開程式不再繼續", "提醒", oldCell)
-
- If oldCell = "*" Then
- Exit Sub
- End If
-
- Wend
-
- '另存新檔
- If oldCell <> "" Then
- '另存新檔
- If istxtFile <> "Y" Then
- '另存新檔
- If FilenameExt = "xls" Then
- objtarget.SaveAs Excel.Workbooks(Source).Path & "" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt, FileFormat:=xlExcel8
- Windows(first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt).Close
- Else
- objtarget.SaveAs Excel.Workbooks(Source).Path & "" & first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt
- Windows(first_name & replace_string(Trim(oldCell)) & last_name & "." & FilenameExt).Close
- End If
- Else
-
- tempfilename = Excel.Workbooks(Source).Path & "" & first_name & replace_string(Trim(oldCell)) & last_name & ".txt"
- ActiveWorkbook.SaveAs Filename:= _
- tempfilename, FileFormat:=xlText, _
- CreateBackup:=False
-
- Excel.Application.DisplayAlerts = False '將Excel警告關閉
- Windows(first_name & replace_string(Trim(oldCell)) & last_name & ".txt").Close
- Excel.Application.DisplayAlerts = True '將Excel警告打開
- End If
- End If
- End If
- '選取來源範圍
- Windows(WorkName).Activate
- oldCell = objsheet.Cells(j, b)
- j = j + 1
- Wend
-
-
-
- '將來源檔案關閉
- Windows(WorkName).Close
-
- MsgBox "處理完畢!!", vbOKOnly, "彰化一整天的blog"
- End Sub
- Function replace_string(ByVal str As String)
- '將工作表中不能用的符號全部轉成_
- str = Replace(str, "/", "_") '將/換成_
- str = Replace(str, "", "_") '將\換成_
- str = Replace(str, "?", "_") '將?換成_
- str = Replace(str, "*", "_") '將*換成_
- str = Replace(str, "[", "_") '將[換成_
- str = Replace(str, "]", "_") '將]換成_
- replace_string = str
- End Function
複製代碼 |
|