回复 楼主 wube
木有附件?
2015-01-30 18:29
2015-01-31 06:38

2015-01-31 08:46
程序代码:Private Sub Command1_Click()
Dim EXAPP As Excel.Application
Dim WB As Excel.Workbook
Dim sht As Excel.Worksheet
Dim temp() As String
Set EXAPP = CreateObject("excel.application")
Set WB = EXAPP.Workbooks.Open("c:\test.xlsx")
Set sht = WB.Worksheets("Sheet1")
temp = Split("012,324.45,adbc,030.32", ",")
sht.Range(cells(1, 1), cells(1, 1 + UBound(temp))).Value = temp
WB.Save
WB.Close
Set sht = Nothing
Set WB = Nothing
Set EXAPP = Nothing
End Sub即使把E1设置为“文本”,excel计算如下图

2015-02-02 09:27
程序代码:
Private Sub Transform(sh As Integer)
Dim xlApp As New EXCEL.Application
Dim xlBook As EXCEL.Workbook
Dim xlsheet As EXCEL.Worksheet
Dim xlRang As EXCEL.Range
Dim SheetNum As Integer, i As Integer
Dim File_name As String
File_name = Mid$(FileNameArray(0), 1, InStrRev(FileNameArray(0), "_")) & Format(Now, "yyyymmddhhmmss") & ".xlsx"
Text1.Text = Mid$(File_name, InStrRev(File_name, "\") + 1): Text1.ToolTipText = File_name
If SheetNum = 0 Then
Set xlApp = CreateObject("Excel.Application")
' xlApp.Visible = True
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlBook = xlApp.Workbooks.Item("Book1")
If UBound(FileNameArray) > 0 Then
For i = 1 To ((UBound(FileNameArray) + 1) + sh)
If i > 3 Then
Set xlsheet = xlBook.Sheets.Add
Else
Set xlsheet = xlBook.Sheets(i)
End If
With xlsheet
.Cells.Font.Name = "Gulim"
.Cells.Font.Size = 10
.Cells.ColumnWidth = 4
.Select
.Cells.Borders.LineStyle = xlContinuous
.Cells.Borders.Weight = xlThin
.Cells.Borders.ColorIndex = 15
xlApp.ActiveWindow.Zoom = 75
End With
DoEvents
Next i
End If
End If
Call ToEXCELItemList(1, xlBook)
Call ToEXCELBinMap(2, xlBook)
Call ToEXCELTestInfo(4, xlBook)
If sh <> 0 Then
Call ToEXCELEveryItem(5, sh, xlBook)
End If
If IsFileExist(File_name) = False Then
xlApp.ActiveWorkbook.SaveAs (File_name)
Else
MsgBox "Error!!!"
End If
xlApp.Visible = True
xlApp.UserControl = True
Set xlRang = Nothing
Set xlsheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
ProgressBar1.Value = 100
End Sub
Private Sub ToEXCELItemList(SheetNumber As Integer, xlBook As Object)
Dim xlsheet As EXCEL.Worksheet
Dim i As Integer, j As Integer, StartNum As Integer, StartNum1 As Integer
Dim Temp() As String, iMax As Double, iMin As Double
Set xlsheet = xlBook.Sheets(SheetNumber)
xlsheet.Name = "TestItemList"
xlsheet.Activate
xlsheet.Cells.HorizontalAlignment = xlCenter
StartNum = 1 ''行
StartNum1 = 1 ''列
With xlsheet
For i = 0 To UBound(ItemListData)
Temp = Split(ItemListData(i), ",")
.Range(.Cells(StartNum + i, StartNum1), .Cells(StartNum + i, StartNum1 + UBound(Temp))).Value = Temp
If i > 4 Then
iMax = 0: iMin = 0
For j = 0 To UBound(Temp)
If j > 8 Then
If ((Trim$(Temp(1)) <> "") And (Trim$(Temp(j)) <> "")) Then
iMax = CDbl(Temp(4)): iMin = CDbl(Temp(3))
If Trim$(Temp(2)) <> "F" Then
If ((CDbl(Temp(j)) < iMin) Or (CDbl(Temp(j) > iMax))) Then
.Cells(StartNum + i, StartNum1 + j).Font.Color = vbRed
End If
End If
End If
End If
DoEvents
Next j
End If
DoEvents
Erase Temp
ProgressBar1.Value = (i / UBound(ItemListData)) * 100
Next i
.Columns.AutoFit
.Rows.AutoFit
.Range("J6").Activate
ActiveWindow.FreezePanes = True
.Columns("I:C").Group
End With
End Sub
Private Sub ToEXCELBinMap(SheetNumber As Integer, xlBook As Object)
Dim xlsheet As EXCEL.Worksheet
Dim iSheet As Integer, i As Integer, j As Integer, StartNum As Integer, StartNum1 As Integer
Dim Temp() As String
For iSheet = 0 To 1
Set xlsheet = xlBook.Sheets(SheetNumber + iSheet)
xlsheet.Name = IIf(i = 0, "HW", "SW")
xlsheet.Activate
xlsheet.Cells.HorizontalAlignment = xlCenter
StartNum = 1 ''行
StartNum1 = 1 ''列
With xlsheet
For i = 0 To UBound(HWBinMapData)
Temp = IIf(iSheet = 0, Split(HWBinMapData(i), ","), Split(SWBinMapData(i), ","))
.Range(.Cells(StartNum + i, StartNum1), .Cells(StartNum + i, StartNum1 + UBound(Temp))).Value = Temp
If Color = True Then
If i > 3 Then
For j = 0 To UBound(Temp)
If j > 0 Then
If Temp(j) <> "" Then
If CheckBinData(2, Temp(j)) = True Then
.Cells(StartNum + i, StartNum + j).Interior.Color = &HFF00&
Else
.Cells(StartNum + i, StartNum + j).Interior.Color = &H8080FF
End If
End If
End If
Next j
End If
End If
DoEvents
Erase Temp
Next i
.Columns.AutoFit
.Rows.AutoFit
End With
Next iSheet
End Sub
Private Sub ToEXCELTestInfo(SheetNumber As Integer, xlBook As Object)
Dim xlsheet As EXCEL.Worksheet
Dim i As Integer, j As Integer, StartNum As Integer, StartNum1 As Integer
Dim Temp() As String
Set xlsheet = xlBook.Sheets(SheetNumber)
xlsheet.Name = "TestInfo"
xlsheet.Activate
xlsheet.Cells.HorizontalAlignment = xlCenter
StartNum = 1 ''行
StartNum1 = 1 ''列
With xlsheet
For i = 0 To UBound(TestDataInfo)
Temp = Split(TestDataInfo(i), ",")
If (UBound(Temp) = -1) Then
.Range(.Cells(StartNum + i, StartNum1), .Cells(StartNum + i, StartNum1 + 0)).Value = ""
Else
.Range(.Cells(StartNum + i, StartNum1), .Cells(StartNum + i, StartNum1 + UBound(Temp))).Value = Temp
End If
DoEvents
Erase Temp
Next i
.Columns.AutoFit
.Rows.AutoFit
.Columns("A:C").HorizontalAlignment = xlGeneral
End With
End Sub
Private Sub ToEXCELEveryItem(SheetNumber As Integer, LastSheetNumber As Integer, xlBook As Object)
Dim xlsheet As EXCEL.Worksheet
Dim i As Integer, j As Integer
Dim Tmp As String
For i = 0 To UBound(SelectItem, 2)
If SelectItem(2, 0) <> "" Then
If ((Trim$(SelectItem(2, i)) <> "") And (InStr(SelectItem(2, i), ",") <> 0)) Then
Set xlsheet = xlBook.Sheets(SheetNumber + i)
Tmp = Trim$(Mid$(SelectItem(2, i), InStr(SelectItem(2, i), ",") + 1))
Tmp = Trim$(Mid$(Tmp, InStrRev(Tmp, "-") + 1))
xlsheet.Name = Tmp & "_Chart"
xlsheet.Activate
xlsheet.Cells.HorizontalAlignment = xlCenter
Call GenerateChart(xlsheet, i, xlsheet.Name)
End If
End If
DoEvents
If UBound(SelectItem, 2) <> 0 Then
ProgressBar2.Value = CInt((i / UBound(SelectItem, 2)) * 100)
End If
Next i
ProgressBar2.Value = 100
End Sub
Private Sub GenerateChart(xlsheet As Object, iCount As Integer, SheetName As String)
Dim oChart As EXCEL.Chart
Dim MyCharts As EXCEL.ChartObjects
Dim MyCharts1 As EXCEL.ChartObject
Dim j As Integer, StartNum As Integer, StartNum1 As Integer
Dim Temp() As String, Temp1() As String, Temp2() As String, Temp3() As String, Tmp() As String
Dim TempString1 As String, TempString2 As String, TempString3 As String
Dim Max As Double, Min As Double, ICNum As Integer
StartNum = 1 ''行
StartNum1 = 1 ''列
With xlsheet
Temp = Split(SelectItem(2, iCount), ",")
If UBound(Temp) = 1 Then
TempString1 = ItemListData(2)
Temp1 = Split(TempString1, ",")
TempString2 = ItemListData(3)
Temp2 = Split(TempString2, ",")
TempString3 = ItemListData(iCount + 5)
Temp3 = Split(TempString3, ",")
ICNum = UBound(Temp3)
For j = 8 To UBound(Temp3)
If Trim$(Temp3(j)) <> "" Then
If j = 8 Then
.Cells(StartNum, StartNum1 + 0).HorizontalAlignment = xlCenter
.Cells(StartNum, StartNum1 + 0) = "X"
.Cells(StartNum, StartNum1 + 0).Interior.ColorIndex = 40
.Cells(StartNum, StartNum1 + 1).HorizontalAlignment = xlCenter
.Cells(StartNum, StartNum1 + 1) = "Y"
.Cells(StartNum, StartNum1 + 1).Interior.ColorIndex = 40
.Cells(StartNum, StartNum1 + 2).HorizontalAlignment = xlCenter
.Cells(StartNum, StartNum1 + 2) = "Site"
.Cells(StartNum, StartNum1 + 2).Interior.ColorIndex = 40
.Cells(StartNum, StartNum1 + 3).HorizontalAlignment = xlCenter
.Cells(StartNum, StartNum1 + 3) = "HW | SW"
.Cells(StartNum, StartNum1 + 3).Interior.ColorIndex = 40
.Cells(StartNum, StartNum1 + 4).HorizontalAlignment = xlCenter
.Cells(StartNum, StartNum1 + 4) = "Result"
.Cells(StartNum, StartNum1 + 4).Interior.ColorIndex = 40
.Range("A1:R1").Borders.LineStyle = xlContinuous
.Cells(StartNum, StartNum1 + 7) = "MAX = " & Format(Temp3(6), "0.000000")
Max = CDbl(Temp3(6))
.Cells(StartNum, StartNum1 + 7).HorizontalAlignment = xlLeft
.Cells(StartNum, StartNum1 + 9) = "MIN = " & Format(Temp3(7), "0.000000")
Min = CDbl(Temp3(7))
.Cells(StartNum, StartNum1 + 9).HorizontalAlignment = xlLeft
.Cells(StartNum, StartNum1 + 11) = "AVG = " & Format(Temp3(8), "0.000000")
.Cells(StartNum, StartNum1 + 11).HorizontalAlignment = xlLeft
.Cells(StartNum, StartNum1 + 13) = "Unit = " & Temp3(5)
.Cells(StartNum, StartNum1 + 13).HorizontalAlignment = xlLeft
Else
Tmp = Split(Temp1(j), "|")
.Cells(StartNum + j - 8, StartNum1 + 0) = Tmp(0) 'X
.Cells(StartNum + j - 8, StartNum1 + 1) = Tmp(1) 'Y
.Cells(StartNum + j - 8, StartNum1 + 2) = Tmp(2) 'Site
.Cells(StartNum + j - 8, StartNum1 + 3) = Temp2(j) 'Bin
.Cells(StartNum + j - 8, StartNum1 + 4) = Format(Temp3(j), ".000000") 'Result
Erase Tmp
End If
End If
DoEvents
Next j
Erase Temp1, Temp2, Temp3
End If
.Columns.AutoFit
.Rows.AutoFit
Erase Temp
Set MyCharts = .ChartObjects
Set MyCharts1 = MyCharts.Add(200, 28, 700, 600)
Set oChart = MyCharts1.Chart
' Debug.Print xlsheet.Cells(StartNum + 1, StartNum1 + 5)
With oChart
.ChartType = xlXYScatterSmooth
.SetSourceData xlsheet.Range(xlsheet.Cells(StartNum + 1, StartNum1 + 4), xlsheet.Cells(StartNum + ICNum - 9, StartNum1 + 4)), xlColumns
.Location xlLocationAsObject, SheetName
End With
With oChart
.Axes(xlValue).Select
With .Axes(xlValue)
.MinimumScale = Min
.MaximumScale = Max
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
.Axes(xlCategory).Select
With .Axes(xlCategory)
.MinimumScale = 0
.MaximumScale = ICNum
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
End With
End With
End Sub

2015-02-02 14:16
2015-02-02 14:20

2015-02-02 14:24



2015-02-02 23:33