excel - オペレーター入力ボックス変数に基づいてデータを個別の Excel シートにルーティングしますか?

Question

うーん、私はこれについてあまり経験がありませんが、次のようになります。私はこのスクリプトを持っており、1週間ほど取り組んでいますが、行き詰まっています。私がやろうとしているのは、測定データを PC DMIS パートプログラムから Excel ワークブックにエクスポートすることです。私はそこまで行きました。今私がやろうとしているのは、オペレーターの入力ボックスから情報を取得し、データをそのワークブック内の別のシートにルーティングする必要があったものを変更することです (この場合は金型キャビティ番号によって)。これが私が行っていることです（私がマークした2つのブロックは、私が最初に持っていたものに追加しようとしているものです）：

'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

score 0 · Accepted Answer

特定のシートへの参照を取得するのに役立つ関数を次に示します。

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

シートが見つからない場合にシートを作成するオプション (デフォルトではオン) があります。

excel - オペレーター入力ボックス変数に基づいてデータを個別の Excel シートにルーティングしますか?

1 に答える 1

Related

Reference