Dim newxls As New Excel.Application
CommonDialog1.FileName = ""
Dim i, r, c As Integer
'Set xlApp = CreateObject("Excel.Application") '創建EXCEL物件
'宣告application 物件
Set newxls = CreateObject("Excel.Application") '創建EXCEL物件
Dim newbook As New Excel.Workbook
Dim newsheet As New Excel.Worksheet
Set newbook = newxls.Workbooks.Add '創建作業薄
Set newsheet = newbook.Worksheets(1) '創建作業表
'20140429 修改
newsheet.Activate '激活
With CommonDialog1
.CancelError = False '在對話框中，按cancel鍵不出現錯誤
.Flags = cdlOFNHideReadOnly & cdlOFNOverwritePrompt
.Filter = "Excel Files (*.xlsx)|*.xlsx" '對話框底部“保存檔案型別“下拉匡顯示的內容"
.FilterIndex = 1 '選擇"保存型別"的第一個值為默認值，即"Excel Files (*.xls)|*.xls"
.ShowSave
'設定Excel內容的格式，現在暫時不用
'With newsheet
' .Cells.Font.Name = "System"
' .Cells.Font.Size = 12
' .Name = "資料串列"
'
' Range(Cells(1, 1), Cells(1, DataGrid1.Columns.Count)).Select
' Selection.HorizontalAlignment = xlCenter
' Selection.VerticalAlignment = xlCenter
' Selection.Merge '合并居中
' .Cells(1, 1) = "匯出excel檔案"
End With
'若 檔案名稱輸入為空時, 判斷為點擊了取消按鈕
If CommonDialog1.FileName = "" Then
newbook.RunAutoMacros (xlAutoClose) '關閉宏
newbook.Close (True)
newxls.Quit
Exit Sub
End If
Me.txtMessage.Visible = True
Dim sum1 As String
Dim sum2 As String
'Dim Peg As Float
If rsPE.RecordCount > 0 Then
For i = 0 To DataGrid1.Columns.Count - 1 '回圈添加表頭
newsheet.Cells(32, i + 1) = DataGrid1.Columns(i).Caption
Next
rsPE.MoveFirst
Do Until rsPE.EOF
r = rsPE.AbsolutePosition '讀取recordset物件當前記錄的序號位置
For c = 0 To DataGrid1.Columns.Count - 1
DataGrid1.Col = c '讀取地c列資料
'文本型別轉數字型別 value
'newsheet.Cells(r + 32, c + 1).NumberFormatLocal = "0_ "
'SendKeys "{F2}"
'SendKeys "{enter}"
If r = 0 Or c = 0 Then
newsheet.Cells(r + 32, c + 1) = DataGrid1.Columns(c)
Else
newsheet.Cells(r + 32, c + 1) = Val(DataGrid1.Columns(c))
'Debug.Print newsheet.Cells(R + 32, 2)
'Sum1 = Sum1 + newsheet.Cells(r + 32, 2)
'Sum2 = Sum2 + newsheet.Cells(r + 32, 3)
End If
If Len(Me.txtMessage.Text) <= 16 Then
Me.txtMessage.Text = Me.txtMessage.Text + "."
Else
Me.txtMessage.Text = "資料加載中,請稍后!"
End If
Next
rsPE.MoveNext
Loop
End If
ExcelFileName = CommonDialog1.FileName
'rs行數
ExcelRol = rsPE.RecordCount
'rs列數
ExcelRow = DataGrid1.Columns.Count
'Dim GR As Integer
'With Me.DataGrid1
' For GR = 0 To ExcelRol - 1
' .Row = GR
' .Col = 1
'
' sum1 = sum1 + Val(.Text)
' Next GR
'End With
'Debug.Print sum1
'Dim GC As Integer
'With Me.DataGrid1
' For GC = 0 To ExcelRol - 1
' .Row = GC
' .Col = 2
' sum2 = sum2 + Val(.Text)
' Next GC
'End With
'Debug.Print sum2
Dim LastRange As String
'Sheet頁右下角編號
LastRange = getExcelColName(ExcelRow)
'英文形式 例如:"Sheet1!$A$32:$CM$41"
Dim RangeEN As String
RangeEN = "Sheet1!$A$32:$" + fristWord + SecondWord + "$" + CStr(32 + ExcelRol)
Debug.Print RangeEN
With newsheet
.Cells(1, 1) = "當前周次:" + WeekStr
.Cells(1, 1).Font.Color = -16776961
.Cells(1, 1).Font.Size = 18
'.Cells(2, 1) = "人力產能比例:" + CStr(Round(Val(sum2 / sum1), 2) * 100) + "%"
.Cells(2, 1).Font.Size = 18
'.Cells(2, 3) = Round(Val(Sum2 / Sum1), 2) * 100 & "%"
'.Cells(2, 3).Font.Size = 18
'.Cells(2, 3).Font.Color = -16776961
'20140429 修改
'所選區域
.Range(Cells(32, 1).Address, Cells(32 + ExcelRol, ExcelRow).Address).Select
With Selection
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=newsheet.Range(RangeEN)
ActiveChart.ChartType = xlColumnStacked
ActiveWindow.ScrollColumn = 1
ActiveSheet.ChartObjects("圖表 1").Activate
.left = 20
.top = 70
ActiveSheet.Shapes("圖表 1").ScaleWidth 3.7, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes("圖表 1").ScaleHeight 1.3, msoFalse, msoScaleFromTopLeft
End With
ActiveSheet.ChartObjects("圖表 1").Activate
ActiveChart.ChartArea.Select
'----------------------------------------------------------------
'sum1 = "=SUM(B33:B" + CStr((33 + ExcelRol - 1)) + ")"
'sum2 = "=SUM(C33:C" + CStr((33 + ExcelRol - 1)) + ")"
'.Cells(1, 5) = sum1
'.Cells(1, 6) = sum2
'.Cells(2, 1) = "本周負荷率:" + CStr(Round(Val(.Cells(1, 6) / .Cells(1, 1)), 2) * 100) + "%"
'.Cells(2, 1).Font.Size = 18
'.Cells(2, 1).Font.Color = -16776961
sum1 = "=SUM(B33:B" + CStr((33 + ExcelRol - 1)) + ")"
sum2 = "=SUM(C33:C" + CStr((33 + ExcelRol - 1)) + ")"
.Cells(1, 27) = sum1
.Cells(1, 28) = sum2
.Cells(2, 1) = "本周負荷率:"
.Cells(2, 1).Font.Size = 18
.Cells(2, 1).Font.Color = -16776961
'.Cells(2, 3) = .Cells(1, 6) / .Cells(1, 5)
.Cells(2, 3).Font.Size = 18
.Cells(2, 3).Font.Color = -16776961
.Cells(2, 3) = "=AB1/AA1"
Range("C2").Select
Selection.NumberFormatLocal = "0.00%"
End With
'Debug.Print ExcelFileName
newsheet.SaveAs FileName:=CommonDialog1.FileName
newbook.RunAutoMacros (xlAutoClose) '關閉宏
newbook.Close (True)
newxls.Quit
Set newsheet = Nothing
Set newbook = Nothing
Set newxls = Nothing
'Set conn = Nothing
'Set rsPE = Nothing
Me.txtMessage.Visible = False
MsgBox "資料匯出成功", vbMsgBoxRight, "提示"
uj5u.com熱心網友回復：
大神來幫我看看 不知道問題出在哪uj5u.com熱心網友回復：
誰能幫我看看啊轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/122861.html
標籤：VBA
上一篇：windows桌面監視
下一篇：vb.net中水晶報表用