Ugggh，我对此并没有多少经验，但是这里有：我有这个脚本，我工作了一周，而且我被卡住了。我想要做的是将PC DMIS零件程序中的测量数据导出到Excel工作簿中。我走得那么远。现在我要做的是修改我必须从操作员输入框获取信息并将数据路由到该工作簿中的单独工作表（在这种情况下通过模腔编号）。这就是我的目标（我标记的两个区块，正是我想要添加到我原来的区域）：
'Option Explicit
Sub Main
'xl Declarations
Dim xlApp As Object
Dim xlWorkbooks As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim count As Integer
Dim xlWorksheets As String
Dim xlWorksheet As String
'pcdlrn declarations And Open ppg
Dim App As Object
Set App = CreateObject("PCDLRN.Application")
Dim Part As Object
Set Part = App.ActivePartProgram
Dim Cmds As Object
Set Cmds = Part.Commands
Dim Cmd As Object
Dim DCmd As Object
Dim DcmdID As Object
Dim fs As Object
Dim DimID As String
Dim ReportDim As String
Dim CheckDim As String
Dim Cavity As String
Dim myValue As String
Dim message, title, defaultValue As String
message = "Cavity"
title = "cavity"
defaultValue = "1"
myValue = InputBox(message, title, defaultValue)
If myValue = "" Then myValue = defaultValue
'Check To see If results file exists
FilePath = "C:\Excel PC DMIS\3K170 B2A\"
Set fs = CreateObject("Scripting.FileSystemObject")
ResFileExists = fs.fileexists(FilePath & Part.partname & ".xls")
'Open Excel And Base form
Set xlApp = CreateObject("Excel.Application")
Set xlWorkbooks = xlapp.Workbooks
If ResFileExists = False Then
TempFilename = FilePath & "Loop Template.xls"
Else
TempFilename = FilePath & Part.partname & ".xls"
End If
Set xlApp = CreateObject("Excel.Application") 'Error start???
Set xlWorkbook = xlWorkbooks.Open(TempFilename)
Set xlSheet = xlWorkbook.Worksheets("Sheet1")
Set xlsheets = xlworkbook.worksheets
Dim sh As Worksheet, flg As Boolean
For Each sh In xlworkbook.worksheets
If sh.Name = myValue Then flg = True: Exit For
Next
If flg = False Then
xlsheets.Add.Name = myValue
End If
Set xlSheet = xlWorkbook.Worksheets(myValue)
'error End ?????
If ResFileExists = False Then
RCount=6
CCount=3
xlSheet.Range("B1").Value = Part.PartName
xlSheet.Range("A6").Value = Date() & " " & Time()
xlSheet.Range("B6").Value = "Inspector Name"
For Each Cmd In Cmds
'Eliminate DATDEF's
If Cmd.Type <> 1299 Then
'Do Dimensions
If Cmd.IsDimension Then
If Cmd.Type = DIMENSION_START_LOCATION Or Cmd.Type = DIMENSION_TRUE_START_POSITION Then
Set DcmdID = Cmd.DimensionCommand
DimID = DcmdID.ID
ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
End If
If Cmd.Type <> DIMENSION_START_LOCATION And Cmd.Type <> DIMENSION_END_LOCATION And _
Cmd.Type <> DIMENSION_TRUE_START_POSITION And Cmd.Type <> DIMENSION_TRUE_END_POSITION Then
Set DCmd = Cmd.DimensionCommand
CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
If CheckDim <> "" Then
ReportDim = CheckDim
End If
If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
If DCmd.ID = "" Then
xlSheet.Cells(5,CCount).Value = DimID & "."& DCmd.AxisLetter
Else
xlSheet.Cells(5,CCount).Value = DCmd.ID & "." & "M"
End If
xlSheet.Cells(2,CCount).Value = DCmd.Nominal
xlSheet.Cells(3,CCount).Value = DCmd.Plus
xlSheet.Cells(4,CCount).Value = DCmd.Minus
'Measured Or Deviation With check For True Position
If DCmd.AxisLetter <> "TP" Then
xlSheet.Cells(6,CCount).Value = DCmd.Measured
Else
xlSheet.Cells(6,CCount).Value = DCmd.Deviation
End If
'Add Min/Max For Profile dimensions
If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
CCount=CCount+1
xlSheet.Cells(5,CCount).Value = DCmd.ID & "." & "Max"
xlSheet.Cells(2,CCount).Value = DCmd.Nominal
xlSheet.Cells(3,CCount).Value = DCmd.Plus
xlSheet.Cells(4,CCount).Value = DCmd.Minus
xlSheet.Cells(6,CCount).Value = DCmd.Max
CCount=CCount+1
xlSheet.Cells(5,CCount).Value = DCmd.ID & "." & "Min"
xlSheet.Cells(2,CCount).Value = DCmd.Nominal
xlSheet.Cells(3,CCount).Value = DCmd.Plus
xlSheet.Cells(4,CCount).Value = DCmd.Minus
xlSheet.Cells(6,CCount).Value = DCmd.Min
End If
CCount=CCount+1
End If
End If
End If
'Do GDT
If Cmd.Type = 184 Then
ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
xlSheet.Cells(5,CCount).Value = Cmd.GetText (ID, 0) & "." & "FCF"
xlSheet.Cells(2,CCount).Value = "0"
xlSheet.Cells(3,CCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1)
xlSheet.Cells(4,CCount).Value = "0"
xlSheet.Cells(6,CCount).Value = Cmd.GetText (LINE2_DEV, 1)
CCount=CCount+1
End If
End If
End If
Next Cmd
Else
'Find first Open column.
RCount=6
Found=0
Do Until Found = 1
RCount = RCount + 1
If xlSheet.Cells(RCount,1).Value = "" Then
Found=1
End If
Loop
xlSheet.Cells(RCount,1).Value = Date() & " " & Time()
xlSheet.Cells(RCount,2).Value= "Inspector Name"
'Fill In measured data
CCount = 3
For Each Cmd In Cmds
'Eliminate DATDEF's
If Cmd.Type <> 1299 Then
'Do Dimensions
If Cmd.IsDimension Then
If Cmd.Type = DIMENSION_START_LOCATION Or Cmd.Type = DIMENSION_TRUE_START_POSITION Then
Set DcmdID = Cmd.DimensionCommand
DimID = DcmdID.ID
ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
End If
If Cmd.Type <> DIMENSION_START_LOCATION And Cmd.Type <> DIMENSION_END_LOCATION And _
Cmd.Type <> DIMENSION_TRUE_START_POSITION And Cmd.Type <> DIMENSION_TRUE_END_POSITION Then
Set DCmd = Cmd.DimensionCommand
CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
If CheckDim <> "" Then
ReportDim = CheckDim
End If
If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
'Measured Or Deviation With check For True Position
If DCmd.AxisLetter <> "TP" Then
xlSheet.Cells(RCount,CCount).Value = DCmd.Measured
Else
xlSheet.Cells(RCount,CCount).Value = DCmd.Deviation
End If
'Add Min/Max For Profile dimensions
If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
CCount=CCount+1
xlSheet.Cells(RCount,CCount).Value = DCmd.Max
CCount=CCount+1
xlSheet.Cells(RCount,CCount).Value = DCmd.Min
End If
Ccount=Ccount+1
End If
End If
End If
'Do GDT
If Cmd.Type = 184 Then
ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
xlSheet.Cells(RCount,CCount).Value = Cmd.GetText (ID, 0) & "." & "FCF"
xlSheet.Cells(RCount,CCount).Value = "0"
xlSheet.Cells(RCount,CCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1)
xlSheet.Cells(RCount,CCount).Value = "0"
xlSheet.Cells(RCount,CCount).Value = Cmd.GetText (LINE2_DEV, 1)
CCount=CCount+1
End If
End If
End If
Next Cmd
End If
'Save And Cleanup
Set xlSheet = Nothing
SaveName = FilePath & Part.partname & ".xls"
If ResFileExists = False Then
xlWorkBook.SaveAs SaveName
Else
xlWorkBook.Save
End If
xlWorkbook.Close
Set xlWorkbook = Nothing
xlWorkbooks.Close
Set xlWorkbooks = Nothing
xlApp.Quit
Set xlApp = Nothing
LabelEnd:
End Sub
答案 0 :(得分：0)
这是一个可以帮助获取对特定工作表的引用的函数：
Function GetSheet(wb As Workbook, wsName As String, _
Optional CreateIfMissing As Boolean = True)
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Sheets(wsName)
On Error GoTo 0
If ws Is Nothing And CreateIfMissing Then
Set ws = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
ws.Name = wsName
End If
Set GetSheet = ws
End Function
如果找不到，则它有一个选项（默认情况下为on）以创建工作表。