hexagon logo

VB output to excel

I have a script that i found on here somewhere that creates excel reports and imports all the data in rows. I would like for the data to be imported in columns. I tried it by changing all the row commands to column and all column commands to row, but with no success. What am i doing wrong?

Also, what did the Let and Set assignment statements change to or what they have been replaced with?

Thanks
Parents
  • Unfortunately not.
    This is the code i'm using. I got this from here years ago but never played with it until now.

    Sub Main
    
    
    'xl Declarations
    Dim xlApp As Object
    Dim xlWorkbooks As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object
    Dim count As Integer
    
    
    '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 DimID As String
    Dim fs As Object
    Dim ReportDim As String
    Dim CheckDim As String
    
    'Check To see If results file exists
    FilePath = "C:\Excel Data\"
    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 xlWorkbook = xlWorkbooks.Open(TempFilename)
    Set xlSheet = xlWorkbook.Worksheets("Sheet1") 
    
    
    If ResFileExists = False Then
        RCount=6
        CCount=3
        xlSheet.Range("B1").Value = Part.PartName
        xlSheet.Range("A6").Value = Date() & " " & Time()
    
        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 = "STATS" Then
                            If DCmd.ID = "" Then
                                    xlSheet.Cells(5,CCount).Value = DimID
                            Else
                                    xlSheet.Cells(5,CCount).Value = DCmd.ID
                            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 = "STATS" 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()
    
    '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 = "STATS" 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 = "STATS" 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
Reply
  • Unfortunately not.
    This is the code i'm using. I got this from here years ago but never played with it until now.

    Sub Main
    
    
    'xl Declarations
    Dim xlApp As Object
    Dim xlWorkbooks As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object
    Dim count As Integer
    
    
    '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 DimID As String
    Dim fs As Object
    Dim ReportDim As String
    Dim CheckDim As String
    
    'Check To see If results file exists
    FilePath = "C:\Excel Data\"
    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 xlWorkbook = xlWorkbooks.Open(TempFilename)
    Set xlSheet = xlWorkbook.Worksheets("Sheet1") 
    
    
    If ResFileExists = False Then
        RCount=6
        CCount=3
        xlSheet.Range("B1").Value = Part.PartName
        xlSheet.Range("A6").Value = Date() & " " & Time()
    
        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 = "STATS" Then
                            If DCmd.ID = "" Then
                                    xlSheet.Cells(5,CCount).Value = DimID
                            Else
                                    xlSheet.Cells(5,CCount).Value = DCmd.ID
                            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 = "STATS" 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()
    
    '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 = "STATS" 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 = "STATS" 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
Children
No Data