麻辣家族討論版版 - Powered by Discuz! Board

Private Sub cmdMerge_Click()
Application.ScreenUpdating = False '屏蔽屏幕刷新
Dim a, b, c As Integer '宣告a,b,c為整數
Dim objsheet As Worksheet
WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
desc = Excel.Workbooks.Add.Name '新檔案視窗編號
Application.DisplayAlerts = False '將警告訊息關閉
i = 6
z = 1
While Windows(WorkName).ActiveSheet.Range("b" & i) <> ""
Filename = Windows(WorkName).ActiveSheet.Range("b" & i) & "." & Windows(WorkName).ActiveSheet.Range("b3")
Workbooks.Open Filename:=Excel.Workbooks(WorkName).Path & "\" & Filename
sheetname = Windows(WorkName).ActiveSheet.Range("b4")
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 '切換視窗
'讀取來源檔案的X(列數),Y(行數)
x = Windows(WorkName).ActiveSheet.Range("b1")
y = Windows(WorkName).ActiveSheet.Range("b2")
a = x '開始列
b = y '開始欄
Do While True
kk = ""
For l = 1 To 10
For k = 1 To 30
If IsError(objsheet.Cells(x + l, k)) = False Then
kk = kk & objsheet.Cells(x + l, k)
End If
Next
Next
If kk = "" Then Exit Do
x = x + 1
Loop
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
'選取來源範圍
objsheet.Range(objsheet.Cells(a, b), objsheet.Cells(x, y)).Select
'copy
Selection.Copy
'選取目的
Windows(desc).Activate
'如果貼上以後會大於1048576則新增一個活頁
If (z + x - a + 1) > 65535 Then
z = 1
Windows(desc).Parent.Sheets.Add
Windows(desc).Parent.Sheets(1).Cells(z, 1).Select
Else
If UCase(Sheet1.Range("b5").Value) = "Y" Then
Windows(desc).ActiveSheet.Cells(z, 1).Value = Windows(WorkName).ActiveSheet.Range("b" & i)
Windows(desc).ActiveSheet.Cells(z, 2).Select
Else
Windows(desc).ActiveSheet.Cells(z, 1).Select
End If
End If
ActiveSheet.Paste
'貼上欄寬
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
z = z + x - a + 1
'將來源檔案關閉
Windows(Filename).Close
i = i + 1 '讀取下一個檔案名稱
Wend
Windows(desc).ActiveSheet.Cells(1, 1).Select
'版面設定上下左右0.5
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.196850393700787)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.196850393700787)
.BottomMargin = Application.InchesToPoints(0.196850393700787)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
'A:F遞增排序
ActiveSheet.Columns("A:F").Select
Selection.Sort Key1:=ActiveSheet.Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNormal
'資料剖析
ActiveSheet.Columns("D:D").Select
Selection.Insert Shift:=xlToRight
ActiveSheet.Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
'整理
ActiveSheet.Range("C1").Select
ActiveCell.FormulaR1C1 = "菜名"
ActiveSheet.Range("D1").Select
ActiveCell.FormulaR1C1 = "單價"
ActiveSheet.Columns("D:D").ColumnWidth = 5.63
Application.DisplayAlerts = True '將警告訊息打開
Application.ScreenUpdating = True '取消屏蔽屏幕刷新
End Sub

複製代碼