Macro läuft auf neuer exselversion nicht

[Hagen]

Moin liebe Gemeinde,

ich hier ein Exceksheet mit einem Macro. Dieses Macro lief bis exsel 2003 einfandfrei. Jetzt haben wir auf Arbeit Exsel 2016 drauf bekommen. Und nix geht mehr. Das Makra ist von eine japaner heschreiben und macht fogendes. Der Button startet eine exe. dem Surftest 400. Soweit funktioniert auch alles. Aber wenn ich die Exsel schliese oder eine neue messung machen möchte kann das Makro die exe nicht mehr schliessen. Das beteute ich muss erst im Taskmanager den Prozess händisch schliessen um eine weiter Messung durchzu führen. Bei meinen alten Exsel gab es hier keine Probleme. Hier ist das Macro aus dem Modul. Ich denke das ihr sofort erkennt was das angepasst werden muss. Vielen Dank. Hier das Macro:

Code:

'‚u1.02‚©‚ç‚̏C³

'EƒGƒLƒXƒ|[ƒgƒtƒ@ƒCƒ‹‚ªŽ©“®ƒŠƒ“ƒN‚µ‚È‚¢‚悤‚ɏC³
'EƒGƒLƒXƒ|[ƒgƒtƒ@ƒCƒ‹‚Ì“ú•t‚ª•Ï‚í‚ç‚È‚¢‚悤‚ÉnowŠÖ”‚ðŽ~‚ß‚½B
'@ŒŽ‚ª‰pŒê•\‹L‚³‚ê‚È‚¢ˆ×A“ú•t‚Í•¶Žš—ñ‚Æ‚µ‚½B(‰pŒê”Å‚Ì‚Ý)
'E¬Ñ‘ƒf[ƒ^“ǂݍž‚Ý’†‚̃ƒbƒZ[ƒW‚ð»ŽžŒv•\Ž¦‚É‚µ‚½B
'EƒOƒ‰ƒtì¬Žž‚Ì‚¿‚ç‚‚«‚𖳂­‚µ‚½B

'V1.20
'E2002/2/20 Še‘Œ¾ŒêØŠ·‘ΉžiƒRƒ}ƒ“ƒhƒ{ƒ^ƒ“’ljÁAƒ_ƒCƒAƒƒOƒV[ƒg’ljÁAŒ¾Œêƒe[ƒuƒ‹ƒV[ƒg"language"’ljÁj

Option Explicit

Public word As String
Sub auto_open()
       Call ejhantei
End Sub
Sub ejhantei()
       Dim FName As String
       Dim RETVALUE As String
       Dim strFilePath As String
       FName = "400Language.ini"
       strFilePath = ActiveWorkbook.Path & "\" & FName

        Dim STR As String, RET As Long
               Open strFilePath For Input As #1
           Do While Not EOF(1)                     'ÅIs‚܂ōs“Ç‚ÝŽæ‚è
                       Line Input #1, STR

               If STR = "Z:J" Then
                   word = "jpn"
                   Close #1
                   End
               End If
               If STR = "Z:E" Then
                   word = "eng"
                   Close #1
                   End

               End If

           Loop
           Close #1
End Sub

'*****************************************************
'   Œ¾ŒêØŠ·i‚v‚n‚q‚k‚cj@iŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Sub world()
   Dim mychart
   Dim lang_no
   Dim leng
   
   DialogSheets("dlog_lang").Show                                      'Œ¾ŒêØŠ·ƒƒjƒ…[•\Ž¦
   
       lang_no = Sheets("Language").Range("b1").Value                  '‘I‘ð‚³‚ê‚½Œ¾Œê”ԍ†‚ðƒV[ƒg"Language"‚Ì
                                                                       'B1‚ÉŠi”[‚·‚éB
       
       Sheets("Language").Columns(lang_no + 2).Copy                    '‘I‘ð‚³‚ê‚½Œ¾Œê‚ð—ñ‚`‚ɃRƒs[‚·‚éB
       Sheets("Language").Columns(1).PasteSpecial
       
   
'    Call DATASHEET_CLEAR
   Call datenow                                                        '“ú•t•\Ž¦ØŠ·

'ƒtƒHƒ“ƒg
   With Sheets("Certificate").Range("A1:Z100").Font
       .Name = "Arial"                                                 '‰ŠúƒtƒHƒ“ƒgÝ’è
   End With
'Œ‹‰Ê•\Ž¦
       With Sheets("Certificate")
           .Range("B43").Value = Sheets("Language").Range("A48").Value '"ƒ[ƒN–¼"
           .Range("C43").Value = Sheets("Language").Range("A49").Value '"ƒTƒ“ƒvƒ‹"
           .Range("D43").Value = Sheets("Language").Range("A50").Value '"‘ª’èŽÒ"
           .Range("E43").Value = Sheets("Language").Range("A51").Value '"Mitutoyo"
           .Range("B44").Value = Sheets("Language").Range("A52").Value '"‘ª’è‹@Ší"
           .Range("C44").Value = Sheets("Language").Range("A53").Value '"SurfTest SJ-201"
           .Range("D44").Value = Sheets("Language").Range("A54").Value '"ƒRƒƒ“ƒg"
           .Range("E44").Value = Sheets("Language").Range("A55").Value '"Ver1.1"
           
           .Range("B47").Value = Sheets("Language").Range("A56").Value '"‹KŠi"
           .Range("D47").Value = Sheets("Language").Range("A57").Value '"‹æŠÖ”"
           .Range("B48").Value = Sheets("Language").Range("A58").Value '"‹Èü"
           .Range("D48").Value = Sheets("Language").Range("A59").Value '"ƒJƒbƒgƒIƒt"
           .Range("B49").Value = Sheets("Language").Range("A60").Value '"‘ª’背ƒ“ƒW"
           .Range("D49").Value = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
       End With
'ƒ{ƒ^ƒ“
       Sheets("Certificate").Activate
       Sheets("Certificate").Shapes("BTN1").Select
           leng = Sheets("Language").Range("A16").Value                        '•¶Žš’·‚³Ý’è
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A2").Value                    '•Ï”ƒtƒHƒ“ƒg
           End With
           Selection.Characters.Text = Sheets("Language").Range("A17").Value   '"‘ª’è"

       Sheets("Certificate").Shapes("BTN2").Select
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A2").Value                    '•Ï”ƒtƒHƒ“ƒg
           End With
           Selection.Characters.Text = Sheets("Language").Range("A18").Value _
           & Chr(10) & Sheets("Language").Range("A19").Value                   '"¬Ñ‘" & Chr(10) & "ì¬"
           
       Sheets("Certificate").Shapes("BTN3").Select
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A2").Value                    '•Ï”ƒtƒHƒ“ƒg
           End With
           Selection.Characters.Text = Sheets("Language").Range("A20").Value   '"¬Ñ‘" & Chr(10) & "´¸½Îß°Ä"
'ƒ^ƒCƒgƒ‹
       ActiveSheet.Shapes("Text Box 45").Select
           leng = Sheets("Language").Range("A24").Value                        '•¶Žš’·‚³Ý’è
           Selection.Characters.Text = Sheets("Language").Range("A23").Value   '"ŒŸ ¸ ¬ Ñ ‘"
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A22").Value                   '•Ï”ƒ^ƒCƒgƒ‹ƒtƒHƒ“ƒg
               .Size = Sheets("Language").Range("A24").Value                   '•¶ŽšƒTƒCƒY
           End With
   
'ƒOƒ‰ƒt•\Ž¦
       ActiveSheet.ChartObjects("chart 32").Activate
       ActiveChart.ChartTitle.Select
           With Selection.Font
               .Name = Sheets("Language").Range("A29").Value                   '"‚l‚r ƒSƒVƒbƒN"
               .Size = Sheets("Language").Range("A30").Value                   '12
           End With
           Set mychart = ActiveSheet.ChartObjects("chart 32")
               mychart.Chart.ChartWizard _
               Title:=Sheets("Language").Range("A27").Value                    '"‘ª’è‹Èü"
               
       ActiveSheet.ChartObjects("chart 33").Activate
       ActiveChart.ChartTitle.Select
           With Selection.Font
               .Name = Sheets("Language").Range("A29").Value                   '"‚l‚r ƒSƒVƒbƒN"
               .Size = Sheets("Language").Range("A30").Value                   '12
           End With
           Set mychart = ActiveSheet.ChartObjects("chart 33")
               mychart.Chart.ChartWizard _
               Title:=Sheets("Language").Range("A28").Value                    '"•]‰¿‹Èü", _
               categorytitle:="[mm]", _
               valuetitle:="[um]"
'ƒtƒHƒ“ƒg
   With Sheets("Certificate").Range("B43:E57").Font
       .Name = Sheets("Language").Range("A2").Value                            '•Ï”ƒtƒHƒ“ƒg
       .Size = 11                                                              '‰ŠúƒTƒCƒYÝ’è
   End With
   
   Worksheets("Certificate").Range("A1").Select

End Sub

'*****************************************************
'   ŒŸ¸¬Ñ‘ÃÞ°ÀiŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Public Sub CommandButton2_Click()
   
   
   Dim mesage1 As String
   Dim msg     As String
   Dim strUNIT As String
   
   Dim msg1 As String
   Dim msg2 As String
   Dim msgtitle1 As String
   Dim msgtitle2 As String
   Dim msgtitle As String
   
       word = Sheets("ej").Range("a1").Value
   
   Call datenow
   
   
   msg2 = Sheets("Language").Range("A34").Value                                '"ƒf[ƒ^“ǂݍž‚Ý‚ðŠJŽn‚µ‚Ü‚·B‚æ‚낵‚¢‚Å‚·‚©H"
   msgtitle2 = Sheets("Language").Range("A35").Value                           '"¬Ñ‘ì¬"
       
   If MsgBox(msg2, vbYesNo + vbQuestion, msgtitle2) = 6 Then
'   ƒJ[ƒ\ƒ‹‚ð»ŽžŒv•\Ž¦
   Application.Cursor = xlWait
           'ƒf[ƒ^“ǂݍž‚ݏˆ—
           Call DATASHEET_CLEAR
           Call RESULT_DELL
           Call CSV_READER
           Call MEASUREMENT_PITCH
           Call CONDTION_STICK
           Call RESULT_STICK
           Call CHART_PARAMETER
           strUNIT = Trim(Mid(Worksheets("DATA").Cells(8, 2), 5))
           If strUNIT = "1" Then
               Call UNIT_MM
           ElseIf strUNIT = "2" Then
               Call UNIT_INCH
           End If
'   ƒJ[ƒ\ƒ‹‚ðƒm[ƒ}ƒ‹•\Ž¦‚É–ß‚·
   Application.Cursor = xlDefault
     End If
End Sub

'*****************************************************
'   “ú•tiŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Sub datenow()
   Dim Today
   Dim myDay As String
   Dim mymonth As String
   Dim myyear As String
   Dim MyDate As String
   
'-----------¬Ñ‘ì¬“ú“o˜^----------------
   Today = Now
   myDay = Day(Today)
   mymonth = Month(Today)
   myyear = Year(Today)
   If Sheets("Language").Range("B1").Value = 1 Then
           MyDate = myyear + "/" + mymonth + "/" + myDay
       Else
           Select Case mymonth
               Case 1
                   mymonth = Sheets("Language").Range("A3").Value      '"Jan"
               Case 2
                   mymonth = Sheets("Language").Range("A4").Value      '"Feb"
               Case 3
                   mymonth = Sheets("Language").Range("A5").Value      '"Mar"
               Case 4
                   mymonth = Sheets("Language").Range("A6").Value      '"Apr"
               Case 5
                   mymonth = Sheets("Language").Range("A7").Value      '"May"
               Case 6
                   mymonth = Sheets("Language").Range("A8").Value      '"Jun"
               Case 7
                   mymonth = Sheets("Language").Range("A9").Value      '"Jul"
               Case 8
                   mymonth = Sheets("Language").Range("A10").Value     '"Aug"
               Case 9
                   mymonth = Sheets("Language").Range("A11").Value     '"Sep"
               Case 10
                   mymonth = Sheets("Language").Range("A12").Value     '"Oct"
               Case 11
                   mymonth = Sheets("Language").Range("A13").Value     '"Nov"
               Case 12
                   mymonth = Sheets("Language").Range("A14").Value     '"Dec"
           End Select
   
           MyDate = myDay + "-" + mymonth + "-" + myyear
   End If
   Sheets("Certificate").Range("E2").Value = MyDate
'------------------------------------------

End Sub

'*****************************************************
'   ¬Ñ‘ƒV[ƒg‚̃GƒNƒXƒ|[ƒgiŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Public Sub CommandButton3_Click()
   Dim msg
   Dim AName
   Dim MYBOOK
   Dim intI As Integer
   Dim mychart
   Dim intDROW     As Integer
   Dim strCDROW    As String

   Dim msg1 As String
   Dim msg2 As String
   Dim msgtitle1 As String
   Dim msgtitle2 As String
   Dim msgtitle As String
   
       word = Sheets("ej").Range("a1").Value
       
   'ƒf[ƒ^‚ª‚È‚©‚Á‚½ê‡ƒGƒNƒXƒ|[ƒg‚µ‚È‚¢B
   If Sheets("data").Range("a1").Value = "" Then
       MsgBox ("No data")
       End
   End If
 
   
   msg2 = Sheets("Language").Range("A38").Value '"¬Ñ‘‚ðƒGƒNƒZƒ‹ƒtƒ@ƒCƒ‹Œ`Ž®‚ŃGƒNƒXƒ|[ƒg‚µ‚Ü‚·B‚æ‚낵‚¢‚Å‚·‚©H"
   msgtitle2 = Sheets("Language").Range("A39").Value '"¬Ñ‘ƒGƒNƒXƒ|[ƒg"
   
   If MsgBox(msg2, vbYesNo + vbQuestion, msgtitle2) = vbYes Then
       AName = ActiveWorkbook.Name                     'ƒƒCƒ“ƒtƒ@ƒCƒ‹–¼Žæ“¾
       
       'ÃÞ°À¼°Ä‚ðƒRƒs[‚µ‚ĐVƒtƒ@ƒCƒ‹‚É“\‚è•t‚¯
       Workbooks(AName).Worksheets("DATA").Copy 'before:=Worksheets("Sheet1")
       '¬Ñ‘¼°Ä‚ðƒRƒs[‚µ‚ĐVƒtƒ@ƒCƒ‹‚É“\‚è•t‚¯
       Workbooks(AName).Worksheets("Certificate").Copy before:=Worksheets("DATA")
       '‘ª’è‹Èüƒf[ƒ^”͈͎擾iŽ©“®ƒŠƒ“ƒN–hŽ~j
       intDROW = Worksheets("DATA").Range("D1").End(xlDown).Row
       strCDROW = "C1:D" & Trim(intDROW)
       Set mychart = ActiveSheet.ChartObjects(1)
       mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       
       '‘e‚³‹Èüƒf[ƒ^”͈͎擾iŽ©“®ƒŠƒ“ƒN–hŽ~j
       intDROW = Worksheets("DATA").Range("F1").End(xlDown).Row
       strCDROW = "E1:F" & Trim(intDROW)
       
       Set mychart = ActiveSheet.ChartObjects(2)
       mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       'ƒRƒ}ƒ“ƒhƒ{ƒ^ƒ“íœ
       ActiveSheet.Shapes.Range(Array("BTN1", "BTN2", "BTN3", "BTN4")).Delete
       Worksheets("Certificate").Range("A1").Copy          'ƒNƒŠƒbƒuƒ{[ƒhã‚̃f[ƒ^‚ª‘å‚«‚¢ˆ×A
       Worksheets("Certificate").Range("A1").PasteSpecial  'ƒtƒ@ƒCƒ‹ƒNƒ[ƒYŽž‚ɃƒbƒZ[ƒW‚ª•\Ž¦‚³‚ê‚éB
                                                           '•\Ž¦‚³‚¹‚È‚¢‚悤‚É‚·‚éˆ×¬—e—ʂ̃_ƒ~[ƒRƒs[‚ðs‚¤B
       ActiveWorkbook.Close SaveChanges:=True              'ƒGƒNƒXƒ|[ƒgƒtƒ@ƒCƒ‹‚ð•Â‚¶‚é
   End If
End Sub

'*****************************************************
'   CSV̧²Ù‚ð“ǂݍž‚ށi‹¤’ʁj
'*****************************************************
Public Sub CSV_READER()
   '•Ï”éŒ¾
   Dim intI        As Integer
   Dim intJ        As Integer
   Dim intRow      As Integer
   Dim strData     As String
   Dim strFilePath As String
   Dim strFileName As String
   Dim msg2, msgtitle2
   On Error GoTo ErrHand
   
   'CSV̧²ÙÃÞ°À‚̎擾
   For intI = 1 To 4
       Select Case intI
           Case 1
               intRow = 1
               strFileName = "Parameter.Csv"
          Case 2
               intRow = 2
               strFileName = "Condition.Csv"
           Case 3
               intRow = 4
               strFileName = "Measured.Csv"
           Case 4
               intRow = 6
               strFileName = "Evaluation.Csv"
       End Select
       
'        strFilePath = ActiveWorkbook.Path & "\DATA" & strFileName
       strFilePath = "C:\ProgramData\Mitutoyo Surftest\SJ-400\" & strFileName
       
       Open strFilePath For Input As #1
           Do While Not EOF(1)
               intJ = intJ + 1
               Line Input #1, strData
               Worksheets("DATA").Cells(intJ, intRow) = strData
           Loop
           intJ = 0
       Close #1
   Next intI
   Exit Sub

ErrHand:
           msg2 = Sheets("Language").Range("A36").Value
           msgtitle2 = Sheets("Language").Range("A37").Value
           MsgBox strFilePath & msg2, vbCritical, msgtitle2
           Application.Cursor = xlDefault
           End
'            End If
'        End If

End Sub

'*****************************************************
'   —ñ‚Ì‘}“ü‚·‚éi‹¤’ʁj
'*****************************************************
Public Sub ROW_INSERTION()
   Worksheets("DATA").Select
   Columns("C:C").Select
   Range("C2").Activate
   Selection.Insert Shift:=xlToRight
   Columns("E:E").Select
   Range("E2").Activate
   Selection.Insert Shift:=xlToRight
End Sub

'*****************************************************
'   ‘ª’èŠÔŠu‚ð‹‚ß‚éi‹¤’ʁj
'*****************************************************
Public Sub MEASUREMENT_PITCH()
   Dim intI        As Integer
   Dim logPIT      As Long
   Dim logLNG      As Long
   Dim logPITCH    As Long
   Dim logLENGTH   As Long
   Dim strUNIT     As String
     
   '’PˆÊ‚ÅŒ…”‚Ì’²®‚ð‚·‚é
   strUNIT = Trim(Mid(Worksheets("DATA").Cells(8, 2), 5))
   If strUNIT = "1" Then
       logPIT = 100
       logLNG = 100000
   ElseIf strUNIT = "2" Then
       logPIT = 10
       logLNG = 10000000
   End If
   
   '»ÝÌßØݸÞË߯Á‚ð‹‚ß‚é
   logPITCH = Val(Mid(Worksheets("DATA").Cells(7, 2), 5)) * logPIT
   '‘ª’è‹Èü
   For intI = 1 To Worksheets("DATA").Range("D1").End(xlDown).Row
       logLENGTH = logLENGTH + logPITCH
       Worksheets("DATA").Cells(intI, 3) = (logLENGTH / logLNG)
  Next intI
   '‘e‚³‹Èü
   logLENGTH = 0
   For intI = 1 To Worksheets("DATA").Range("F1").End(xlDown).Row
       logLENGTH = logLENGTH + logPITCH
       Worksheets("DATA").Cells(intI, 5) = (logLENGTH / logLNG)
   Next intI
End Sub

'*****************************************************
'   ÃÞ°À°¼°Ä¸Ø±°i‹¤’ʁj
'*****************************************************
Public Sub DATASHEET_CLEAR()
  Worksheets("DATA").Cells.ClearContents
End Sub

'*****************************************************
'  ƒOƒ‰ƒtƒXƒpƒ‰ƒ[ƒ^“ü—́i‹¤’ʁj
'*****************************************************
Public Sub CHART_PARAMETER()
   Dim intDROW     As Integer
   Dim dblLENG     As Double
   Dim strCDROW    As String
   Dim strProfile  As String
   Dim mychart
   Dim prof
   '‘ª’è‹Èü
       intDROW = Worksheets("DATA").Range("D1").End(xlDown).Row
       strCDROW = "C1:D" & Trim(intDROW)
           Set mychart = ActiveSheet.ChartObjects("chart 32")
           mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       dblLENG = Worksheets("DATA").Range("C" & intDROW)
       With mychart.Chart _
           .Axes(xlCategory)
           .MinimumScale = 0
           .MaximumScale = dblLENG
       End With
       Call XAXIS_KETA(dblLENG, mychart)

   '•]‰¿‹Èü
       intDROW = Worksheets("DATA").Range("F1").End(xlDown).Row
       strCDROW = "E1:F" & Trim(intDROW)
           Set mychart = ActiveSheet.ChartObjects("chart 33")
           mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       dblLENG = Worksheets("DATA").Range("E" & intDROW)
       With mychart.Chart _
           .Axes(xlCategory)
           .MinimumScale = 0
           .MaximumScale = dblLENG
       End With
       '•]‰¿‹Èü–¼Ì
       strProfile = Trim(Mid(Worksheets("DATA").Cells(3, 2), 4))
       If strProfile = "MOTIF" Then
           strProfile = "P"
       End If
                       prof = Sheets("Language").Range("A58").Value
                       mychart.Chart.ChartWizard Title:=strProfile & prof
       Call XAXIS_KETA(dblLENG, mychart)

   Worksheets("Certificate").Range("A1").Select
End Sub

'*****************************************************
'  ƒ`ƒƒ[ƒg‚ÌXŽ²‚ÌŒ…‚𒲐®‚·‚éi‹¤’ʁj
'*****************************************************
Public Sub XAXIS_KETA(dblLENG, mychart)
   
   If dblLENG < 0.05 Then
           mychart.Chart.Axes(xlCategory).TickLabels.NumberFormat = "0.000_ "
   ElseIf dblLENG >= 0.05 And dblLENG < 1 Then
           mychart.Chart.Axes(xlCategory).TickLabels.NumberFormat = "0.00_ "
   ElseIf dblLENG >= 1 Then
           mychart.Chart.Axes(xlCategory).TickLabels.NumberFormat = "0.0_ "
   End If
End Sub

'*****************************************************
'  ƒ`ƒƒ[ƒg‚Ì’PˆÊ‚ðinch‚ɐ؂è‘Ö‚¦‚éi‹¤’ʁj
'*****************************************************
Public Sub UNIT_INCH()
   Dim mychart
       Set mychart = ActiveSheet.ChartObjects("chart 32")
           mychart.Chart.ChartWizard _
           categorytitle:="[inch]", _
           valuetitle:="[uinch]"
   
       Set mychart = ActiveSheet.ChartObjects("chart 33")
           mychart.Chart.ChartWizard _
           categorytitle:="[inch]", _
           valuetitle:="[uinch]"
         
End Sub

'*****************************************************
'  ƒ`ƒƒ[ƒg‚Ì’PˆÊ‚ðmm‚ɐ؂è‘Ö‚¦‚éi‹¤’ʁj
'*****************************************************
Public Sub UNIT_MM()
   Dim mychart
       Set mychart = ActiveSheet.ChartObjects("chart 32")
           mychart.Chart.ChartWizard _
           categorytitle:="[mm]", _
           valuetitle:="[um]"
           
   
       Set mychart = ActiveSheet.ChartObjects("chart 33")
           mychart.Chart.ChartWizard _
           categorytitle:="[mm]", _
           valuetitle:="[um]"
   
End Sub

'*****************************************************
'  I—¹i‹¤’ʁj
'*****************************************************
Sub syuryo()
   End
   
End Sub


'***************************@‚±‚±‚܂Ł@‹¤’ʁ@**************************






'*****************************************************
'   ‘ª’èðŒ“\‚è•t‚¯i‹@Žíê—pSJ401j
'*****************************************************
Public Sub CONDTION_STICK()
   '‹KŠi
   Worksheets("Certificate").Cells(47, 3) = Trim(Mid(Worksheets("DATA").Cells(5, 2), 4))
   '‹Èü
   Worksheets("Certificate").Cells(48, 3) = Trim(Mid(Worksheets("DATA").Cells(3, 2), 4))
   'ƒŒƒ“ƒW
   Worksheets("Certificate").Cells(49, 3) = Trim(Mid(Worksheets("DATA").Cells(6, 2), 4))
   '‹æŠÖ”@‘ª’è’·‚³
   Worksheets("Certificate").Cells(47, 5) = Trim(Mid(Worksheets("DATA").Cells(2, 2), 4))
   '‹æŠÔ•\‹L
       If Trim(Left(Worksheets("DATA").Cells(2, 2), 1)) = "L" Then
            Worksheets("Certificate").Cells(47, 4) = Sheets("Language").Range("A41").Value '"•]‰¿’·‚³"
        Else
            Worksheets("Certificate").Cells(47, 4) = "N"
        End If
   '‹Èü‚É‚æ‚é•\‹L
       If Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "R MOTIF" Or _
          Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "W MOTIF" Then
           Worksheets("Certificate").Cells(47, 4) = Sheets("Language").Range("A41").Value '"•]‰¿’·‚³"
           Worksheets("Certificate").Cells(48, 4) = "A"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 4))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       ElseIf Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "P" And Trim(Left(Worksheets("DATA").Cells(2, 2), 1)) <> "L" Then
           Worksheets("Certificate").Cells(48, 4) = "L"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 4))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       ElseIf Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "W" Then
           Worksheets("Certificate").Cells(48, 4) = "fh-ƒÉf/fl"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 10))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       Else
           Worksheets("Certificate").Cells(48, 4) = Sheets("Language").Range("A44").Value '"ƒJƒbƒgƒIƒt"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 4))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       End If
       If Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "W MOTIF" Then
           Worksheets("Certificate").Cells(49, 4) = "B"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(10, 2), 4))
       End If
       If Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "R MOTIF" Then
           Worksheets("Certificate").Cells(49, 4) = "ANX"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       End If
End Sub

'*****************************************************
'   ÃÞ°À“ǍžÀÞ²±Û¸Þ•\Ž¦i‹@Žíê—pSJ401j
'*****************************************************
Public Sub CommandButton1_Click()
   '•Ï”éŒ¾
   Dim strSurfPath As String
   word = Sheets("ej").Range("a1").Value
   
       If word = "eng" Then
           strSurfPath = ActiveWorkbook.Path & "\Surftest SJ400.exe"
       Else
           If word = "jpn" Then
           strSurfPath = ActiveWorkbook.Path & "\Surftest SJ400.exe"
           End If
       End If
   
   
   'AP‹N“®
   Shell strSurfPath, vbNormalFocus
End Sub

'*****************************************************
'   ‰‰ŽZŒ‹‰Ê“\‚è•t‚¯i‹@Žíê—pSJ300/400j
'*****************************************************
Public Sub RESULT_STICK()
   Dim intI       As Integer
   Dim intComp    As Integer
   Dim strPar     As String
   
'    For intI = 1 To 24
'        If intI <= 12 Then
'            Worksheets("Certificate").Cells(51 + intI, 2) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
'            Worksheets("Certificate").Cells(51 + intI, 3) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
'        Else
'            Worksheets("Certificate").Cells(51 + intI - 12, 4) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
'            Worksheets("Certificate").Cells(51 + intI - 12, 5) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
'        End If
'    Next intI

 
   For intI = 1 To 24
       If intI <= 12 Then
           'ƒpƒ‰ƒ[ƒ^–¼
           strPar = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           'Rz1maxƒpƒ‰ƒ[ƒ^‚ªRz1m‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×AŒã‚Ìax‚ð’ljÁ‚µ‚ĕ₤
           If InStr(strPar, "z1m") > 0 Then strPar = strPar & "ax"
           'Rmr(c)ƒpƒ‰ƒ[ƒ^‚ªRmrc‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×ARmr(c)‘‚«Š·‚¦‚é
           If InStr(strPar, "mrc") > 0 Then strPar = Left(strPar, 1) & "mr(c)"
           Worksheets("Certificate").Cells(51 + intI, 2) = strPar
           'Worksheets("Certificate").Cells(51 + intI, 2) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           Worksheets("Certificate").Cells(51 + intI, 3) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
       Else
           'ƒpƒ‰ƒ[ƒ^–¼
           strPar = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           'Rz1maxƒpƒ‰ƒ[ƒ^‚ªRz1m‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×AŒã‚Ìax‚ð’ljÁ‚µ‚ĕ₤
           If InStr(strPar, "z1m") > 0 Then strPar = strPar & "ax"
           'Rmr(c)ƒpƒ‰ƒ[ƒ^‚ªRmrc‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×ARmr(c)‘‚«Š·‚¦‚é
           If InStr(strPar, "mrc") > 0 Then strPar = Left(strPar, 1) & "mr(c)"
           Worksheets("Certificate").Cells(51 + intI - 12, 4) = strPar
           'Worksheets("Certificate").Cells(51 + intI - 12, 4) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           Worksheets("Certificate").Cells(51 + intI - 12, 5) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
       End If
   Next intI



End Sub

'*****************************************************
'   ‰‰ŽZŒ‹‰Ê•\Ž¦íœi‹@Žíê—pSJ300/400j
'*****************************************************
Public Sub RESULT_DELL()
   Worksheets("Certificate").Range("B52:E63").ClearContents
End Sub

[WillWissen]

Hallo Hagen,

bitte stelle uns den Code nochmals zur Verfügung, indem du ihn direkt aus dem VBA-Editor kopierst und hier einstellst. Benutze bitte den 5. Schalter von rechts:

[
Bild bitte so als Datei hochladen: Klick mich!
]

[Käpt'n Blaubär]

Hallo,

Dieses Macro lief bis exsel 2003 einfandfrei. Jetzt haben wir auf Arbeit Exsel 2016 drauf bekommen. Und nix geht mehr.

also, ein Sprung von Excel2003 auf Excel 2016, das ist schon verdammt hammerhart zu nennen.
Die Zeiträume dazwischen hat MS genutzt, um einige Funktionalitäten neu zu erfinden, aber gleichzeitig
auch, um andere auszuknipsen. Darunter leidest nicht nur Du.

Vielleicht wird ja Günter's Bitte

... bitte stelle uns den Code nochmals zur Verfügung, indem du ihn direkt aus dem VBA-Editor kopierst und hier einstellst. 

der Sache gerecht, aber ich fürchte, da kommt der Code ja gerade her und erneutes Kopieren wird beim Helfen nicht sehr viel helfen.
Ich weiß nicht, wie andere darüber denken, aber ich hätte gerne was Handfestes, womit man testen kann, und würde darum eher um
die ganze Datei bitten.

[RPP63]

Moin auch von mir!

Es geht ja wohl um eine multilinguale Excel-Datei, deren "Betriebssprache" per .INI angepasst wird.
Ich hätte gerne die (ehemals) japanischen Kommentare im Code ins Deutsche übersetzt.  :21:

Und nix geht mehr.

Ich liebe konkrete Fehlerbeschreibungen! 
Was funktioniert wo nicht?
Stoppt der Code?
Wenn ja, wo und mit welcher Fehlermeldung?
…
@Peter:
Ich sehe beim ersten Überfliegen des Codes nichts, was nicht "gehen" sollte.

Gruß Ralf

[Käpt'n Blaubär]

Hallo Ralf,

Deine Kommentare  sind für mich absolut in Ordnung und auch ich hätte gerne

Ich hätte gerne die (ehemals) japanischen Kommentare im Code ins Deutsche übersetzt.  [img]
Dateiupload bitte im Forum! So geht es: Klick mich!
]

Im Grunde weiß ich jetzt im Nachhinein auch nicht mehr so wirklich, warum ich Hagen nicht
direkt gefragt habe, ob er das vielleicht Übersetzen könnte. Na ja, jetzt habe ich es ja gefragt  :05:

[RPP63]

Und noch ergänzend:
14 nicht verwendete Variablen in 19 Prozeduren bei gerade mal 556 Zeilen Code zeugen von schlampiger Programmierung.
Im übrigen empfinde ich das kopieren des gesamten Codes (jetzt macht mal schön) gelinde gesagt als (ohne Worte).
Was soll hier eine Verzweigung, wenn ohnehin das Gleiche ausgeführt wird??

Code:

Public Sub CommandButton1_Click()
  '•Ï”éŒ¾
  Dim strSurfPath As String
  word = Sheets("ej").Range("a1").Value
 
      If word = "eng" Then
          strSurfPath = ActiveWorkbook.Path & "\Surftest SJ400.exe"
      Else
          If word = "jpn" Then
          strSurfPath = ActiveWorkbook.Path & "\Surftest SJ400.exe"
          End If
      End If
 
 
  'AP‹N“®
  Shell strSurfPath, vbNormalFocus
End Sub

Aber wenn ich die Exsel schliese oder eine neue messung machen möchte kann das Makro die exe nicht mehr schliessen.

 Wenn Du mir noch verrätst, wo dies im Code hinterlegt sein soll, könnte dies helfen.

Gruß Ralf

[RPP63]

Während ich noch auf die Antwort warte:
Es könnte helfen, den bei Dir nicht verwendeten optionalen Parameter der Shell-Funktion auf True zu setzen:

Code:

Shell strSurfPath, vbNormalFocus, True

Gruß Ralf

[Hagen]

Code:

'‚u1.02‚©‚ç‚̏C³
'EƒGƒLƒXƒ|[ƒgƒtƒ@ƒCƒ‹‚ªŽ©“®ƒŠƒ“ƒN‚µ‚È‚¢‚悤‚ɏC³
'EƒGƒLƒXƒ|[ƒgƒtƒ@ƒCƒ‹‚Ì“ú•t‚ª•Ï‚í‚ç‚È‚¢‚悤‚ÉnowŠÖ”‚ðŽ~‚ß‚½B
'@ŒŽ‚ª‰pŒê•\‹L‚³‚ê‚È‚¢ˆ×A“ú•t‚Í•¶Žš—ñ‚Æ‚µ‚½B(‰pŒê”Å‚Ì‚Ý)
'E¬Ñ‘ƒf[ƒ^“ǂݍž‚Ý’†‚̃ƒbƒZ[ƒW‚ð»ŽžŒv•\Ž¦‚É‚µ‚½B
'EƒOƒ‰ƒtì¬Žž‚Ì‚¿‚ç‚‚«‚𖳂­‚µ‚½B

'V1.20
'E2002/2/20 Še‘Œ¾ŒêØŠ·‘ΉžiƒRƒ}ƒ“ƒhƒ{ƒ^ƒ“’ljÁAƒ_ƒCƒAƒƒOƒV[ƒg’ljÁAŒ¾Œêƒe[ƒuƒ‹ƒV[ƒg"language"’ljÁj

Option Explicit

Public word As String
Sub auto_open()
       Call ejhantei
End Sub
Sub ejhantei()
       Dim FName As String
       Dim RETVALUE As String
       Dim strFilePath As String
       FName = "400Language.ini"
       strFilePath = ActiveWorkbook.Path & "\" & FName

        Dim STR As String, RET As Long
               Open strFilePath For Input As #1
           Do While Not EOF(1)                     'ÅIs‚܂ōs“Ç‚ÝŽæ‚è
                       Line Input #1, STR

               If STR = "Z:J" Then
                   word = "jpn"
                   Close #1
                   End
               End If
               If STR = "Z:E" Then
                   word = "eng"
                   Close #1
                   End

               End If

           Loop
           Close #1
End Sub

'*****************************************************
'   Œ¾ŒêØŠ·i‚v‚n‚q‚k‚cj@iŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Sub world()
   Dim mychart
   Dim lang_no
   Dim leng
   
   DialogSheets("dlog_lang").Show                                      'Œ¾ŒêØŠ·ƒƒjƒ…[•\Ž¦
   
       lang_no = Sheets("Language").Range("b1").Value                  '‘I‘ð‚³‚ê‚½Œ¾Œê”ԍ†‚ðƒV[ƒg"Language"‚Ì
                                                                       'B1‚ÉŠi”[‚·‚éB
       
       Sheets("Language").Columns(lang_no + 2).Copy                    '‘I‘ð‚³‚ê‚½Œ¾Œê‚ð—ñ‚`‚ɃRƒs[‚·‚éB
       Sheets("Language").Columns(1).PasteSpecial
       
   
'    Call DATASHEET_CLEAR
   Call datenow                                                        '“ú•t•\Ž¦ØŠ·

'ƒtƒHƒ“ƒg
   With Sheets("Certificate").Range("A1:Z100").Font
       .Name = "Arial"                                                 '‰ŠúƒtƒHƒ“ƒgÝ’è
   End With
'Œ‹‰Ê•\Ž¦
       With Sheets("Certificate")
           .Range("B43").Value = Sheets("Language").Range("A48").Value '"ƒ[ƒN–¼"
           .Range("C43").Value = Sheets("Language").Range("A49").Value '"ƒTƒ“ƒvƒ‹"
           .Range("D43").Value = Sheets("Language").Range("A50").Value '"‘ª’èŽÒ"
           .Range("E43").Value = Sheets("Language").Range("A51").Value '"Mitutoyo"
           .Range("B44").Value = Sheets("Language").Range("A52").Value '"‘ª’è‹@Ší"
           .Range("C44").Value = Sheets("Language").Range("A53").Value '"SurfTest SJ-201"
           .Range("D44").Value = Sheets("Language").Range("A54").Value '"ƒRƒƒ“ƒg"
           .Range("E44").Value = Sheets("Language").Range("A55").Value '"Ver1.1"
           
           .Range("B47").Value = Sheets("Language").Range("A56").Value '"‹KŠi"
           .Range("D47").Value = Sheets("Language").Range("A57").Value '"‹æŠÖ”"
           .Range("B48").Value = Sheets("Language").Range("A58").Value '"‹Èü"
           .Range("D48").Value = Sheets("Language").Range("A59").Value '"ƒJƒbƒgƒIƒt"
           .Range("B49").Value = Sheets("Language").Range("A60").Value '"‘ª’背ƒ“ƒW"
           .Range("D49").Value = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
       End With
'ƒ{ƒ^ƒ“
       Sheets("Certificate").Activate
       Sheets("Certificate").Shapes("BTN1").Select
           leng = Sheets("Language").Range("A16").Value                        '•¶Žš’·‚³Ý’è
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A2").Value                    '•Ï”ƒtƒHƒ“ƒg
           End With
           Selection.Characters.Text = Sheets("Language").Range("A17").Value   '"‘ª’è"

       Sheets("Certificate").Shapes("BTN2").Select
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A2").Value                    '•Ï”ƒtƒHƒ“ƒg
           End With
           Selection.Characters.Text = Sheets("Language").Range("A18").Value _
           & Chr(10) & Sheets("Language").Range("A19").Value                   '"¬Ñ‘" & Chr(10) & "ì¬"
           
       Sheets("Certificate").Shapes("BTN3").Select
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A2").Value                    '•Ï”ƒtƒHƒ“ƒg
           End With
           Selection.Characters.Text = Sheets("Language").Range("A20").Value   '"¬Ñ‘" & Chr(10) & "´¸½Îß°Ä"
'ƒ^ƒCƒgƒ‹
       ActiveSheet.Shapes("Text Box 45").Select
           leng = Sheets("Language").Range("A24").Value                        '•¶Žš’·‚³Ý’è
           Selection.Characters.Text = Sheets("Language").Range("A23").Value   '"ŒŸ ¸ ¬ Ñ ‘"
           With Selection.Characters(Start:=1, Length:=leng).Font              '•¶Žš’·‚³
               .Name = Sheets("Language").Range("A22").Value                   '•Ï”ƒ^ƒCƒgƒ‹ƒtƒHƒ“ƒg
               .Size = Sheets("Language").Range("A24").Value                   '•¶ŽšƒTƒCƒY
           End With
   
'ƒOƒ‰ƒt•\Ž¦
       ActiveSheet.ChartObjects("chart 32").Activate
       ActiveChart.ChartTitle.Select
           With Selection.Font
               .Name = Sheets("Language").Range("A29").Value                   '"‚l‚r ƒSƒVƒbƒN"
               .Size = Sheets("Language").Range("A30").Value                   '12
           End With
           Set mychart = ActiveSheet.ChartObjects("chart 32")
               mychart.Chart.ChartWizard _
               Title:=Sheets("Language").Range("A27").Value                    '"‘ª’è‹Èü"
               
       ActiveSheet.ChartObjects("chart 33").Activate
       ActiveChart.ChartTitle.Select
           With Selection.Font
               .Name = Sheets("Language").Range("A29").Value                   '"‚l‚r ƒSƒVƒbƒN"
               .Size = Sheets("Language").Range("A30").Value                   '12
           End With
           Set mychart = ActiveSheet.ChartObjects("chart 33")
               mychart.Chart.ChartWizard _
               Title:=Sheets("Language").Range("A28").Value                    '"•]‰¿‹Èü", _
               categorytitle:="[mm]", _
               valuetitle:="[um]"
'ƒtƒHƒ“ƒg
   With Sheets("Certificate").Range("B43:E57").Font
       .Name = Sheets("Language").Range("A2").Value                            '•Ï”ƒtƒHƒ“ƒg
       .Size = 11                                                              '‰ŠúƒTƒCƒYÝ’è
   End With
   
   Worksheets("Certificate").Range("A1").Select

End Sub

'*****************************************************
'   ŒŸ¸¬Ñ‘ÃÞ°ÀiŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Public Sub CommandButton2_Click()
   
   
   Dim mesage1 As String
   Dim msg     As String
   Dim strUNIT As String
   
   Dim msg1 As String
   Dim msg2 As String
   Dim msgtitle1 As String
   Dim msgtitle2 As String
   Dim msgtitle As String
   
       word = Sheets("ej").Range("a1").Value
   
   Call datenow
   
   
   msg2 = Sheets("Language").Range("A34").Value                                '"ƒf[ƒ^“ǂݍž‚Ý‚ðŠJŽn‚µ‚Ü‚·B‚æ‚낵‚¢‚Å‚·‚©H"
   msgtitle2 = Sheets("Language").Range("A35").Value                           '"¬Ñ‘ì¬"
       
   If MsgBox(msg2, vbYesNo + vbQuestion, msgtitle2) = 6 Then
'   ƒJ[ƒ\ƒ‹‚ð»ŽžŒv•\Ž¦
   Application.Cursor = xlWait
           'ƒf[ƒ^“ǂݍž‚ݏˆ—
           Call DATASHEET_CLEAR
           Call RESULT_DELL
           Call CSV_READER
           Call MEASUREMENT_PITCH
           Call CONDTION_STICK
           Call RESULT_STICK
           Call CHART_PARAMETER
           strUNIT = Trim(Mid(Worksheets("DATA").Cells(8, 2), 5))
           If strUNIT = "1" Then
               Call UNIT_MM
           ElseIf strUNIT = "2" Then
               Call UNIT_INCH
           End If
'   ƒJ[ƒ\ƒ‹‚ðƒm[ƒ}ƒ‹•\Ž¦‚É–ß‚·
   Application.Cursor = xlDefault
     End If
End Sub

'*****************************************************
'   “ú•tiŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Sub datenow()
   Dim Today
   Dim myDay As String
   Dim mymonth As String
   Dim myyear As String
   Dim MyDate As String
   
'-----------¬Ñ‘ì¬“ú“o˜^----------------
   Today = Now
   myDay = Day(Today)
   mymonth = Month(Today)
   myyear = Year(Today)
   If Sheets("Language").Range("B1").Value = 1 Then
           MyDate = myyear + "/" + mymonth + "/" + myDay
       Else
           Select Case mymonth
               Case 1
                   mymonth = Sheets("Language").Range("A3").Value      '"Jan"
               Case 2
                   mymonth = Sheets("Language").Range("A4").Value      '"Feb"
               Case 3
                   mymonth = Sheets("Language").Range("A5").Value      '"Mar"
               Case 4
                   mymonth = Sheets("Language").Range("A6").Value      '"Apr"
               Case 5
                   mymonth = Sheets("Language").Range("A7").Value      '"May"
               Case 6
                   mymonth = Sheets("Language").Range("A8").Value      '"Jun"
               Case 7
                   mymonth = Sheets("Language").Range("A9").Value      '"Jul"
               Case 8
                   mymonth = Sheets("Language").Range("A10").Value     '"Aug"
               Case 9
                   mymonth = Sheets("Language").Range("A11").Value     '"Sep"
               Case 10
                   mymonth = Sheets("Language").Range("A12").Value     '"Oct"
               Case 11
                   mymonth = Sheets("Language").Range("A13").Value     '"Nov"
               Case 12
                   mymonth = Sheets("Language").Range("A14").Value     '"Dec"
           End Select
   
           MyDate = myDay + "-" + mymonth + "-" + myyear
   End If
   Sheets("Certificate").Range("E2").Value = MyDate
'------------------------------------------

End Sub

'*****************************************************
'   ¬Ñ‘ƒV[ƒg‚̃GƒNƒXƒ|[ƒgiŒ¾ŒêØŠ·‹¤’ʁj
'*****************************************************
Public Sub CommandButton3_Click()
   Dim msg
   Dim AName
   Dim MYBOOK
   Dim intI As Integer
   Dim mychart
   Dim intDROW     As Integer
   Dim strCDROW    As String

   Dim msg1 As String
   Dim msg2 As String
   Dim msgtitle1 As String
   Dim msgtitle2 As String
   Dim msgtitle As String
   
       word = Sheets("ej").Range("a1").Value
       
   'ƒf[ƒ^‚ª‚È‚©‚Á‚½ê‡ƒGƒNƒXƒ|[ƒg‚µ‚È‚¢B
   If Sheets("data").Range("a1").Value = "" Then
       MsgBox ("No data")
       End
   End If
 
   
   msg2 = Sheets("Language").Range("A38").Value '"¬Ñ‘‚ðƒGƒNƒZƒ‹ƒtƒ@ƒCƒ‹Œ`Ž®‚ŃGƒNƒXƒ|[ƒg‚µ‚Ü‚·B‚æ‚낵‚¢‚Å‚·‚©H"
   msgtitle2 = Sheets("Language").Range("A39").Value '"¬Ñ‘ƒGƒNƒXƒ|[ƒg"
   
   If MsgBox(msg2, vbYesNo + vbQuestion, msgtitle2) = vbYes Then
       AName = ActiveWorkbook.Name                     'ƒƒCƒ“ƒtƒ@ƒCƒ‹–¼Žæ“¾
       
       'ÃÞ°À¼°Ä‚ðƒRƒs[‚µ‚ĐVƒtƒ@ƒCƒ‹‚É“\‚è•t‚¯
       Workbooks(AName).Worksheets("DATA").Copy 'before:=Worksheets("Sheet1")
       '¬Ñ‘¼°Ä‚ðƒRƒs[‚µ‚ĐVƒtƒ@ƒCƒ‹‚É“\‚è•t‚¯
       Workbooks(AName).Worksheets("Certificate").Copy before:=Worksheets("DATA")
       '‘ª’è‹Èüƒf[ƒ^”͈͎擾iŽ©“®ƒŠƒ“ƒN–hŽ~j
       intDROW = Worksheets("DATA").Range("D1").End(xlDown).Row
       strCDROW = "C1:D" & Trim(intDROW)
       Set mychart = ActiveSheet.ChartObjects(1)
       mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       
       '‘e‚³‹Èüƒf[ƒ^”͈͎擾iŽ©“®ƒŠƒ“ƒN–hŽ~j
       intDROW = Worksheets("DATA").Range("F1").End(xlDown).Row
       strCDROW = "E1:F" & Trim(intDROW)
       
       Set mychart = ActiveSheet.ChartObjects(2)
       mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       'ƒRƒ}ƒ“ƒhƒ{ƒ^ƒ“íœ
       ActiveSheet.Shapes.Range(Array("BTN1", "BTN2", "BTN3", "BTN4")).Delete
       Worksheets("Certificate").Range("A1").Copy          'ƒNƒŠƒbƒuƒ{[ƒhã‚̃f[ƒ^‚ª‘å‚«‚¢ˆ×A
       Worksheets("Certificate").Range("A1").PasteSpecial  'ƒtƒ@ƒCƒ‹ƒNƒ[ƒYŽž‚ɃƒbƒZ[ƒW‚ª•\Ž¦‚³‚ê‚éB
                                                           '•\Ž¦‚³‚¹‚È‚¢‚悤‚É‚·‚éˆ×¬—e—ʂ̃_ƒ~[ƒRƒs[‚ðs‚¤B
       ActiveWorkbook.Close SaveChanges:=True              'ƒGƒNƒXƒ|[ƒgƒtƒ@ƒCƒ‹‚ð•Â‚¶‚é
   End If
End Sub

'*****************************************************
'   CSV̧²Ù‚ð“ǂݍž‚ށi‹¤’ʁj
'*****************************************************
Public Sub CSV_READER()
   '•Ï”éŒ¾
   Dim intI        As Integer
   Dim intJ        As Integer
   Dim intRow      As Integer
   Dim strData     As String
   Dim strFilePath As String
   Dim strFileName As String
   Dim msg2, msgtitle2
   On Error GoTo ErrHand
   
   'CSV̧²ÙÃÞ°À‚̎擾
   For intI = 1 To 4
       Select Case intI
           Case 1
               intRow = 1
               strFileName = "Parameter.Csv"
          Case 2
               intRow = 2
               strFileName = "Condition.Csv"
           Case 3
               intRow = 4
               strFileName = "Measured.Csv"
           Case 4
               intRow = 6
               strFileName = "Evaluation.Csv"
       End Select
       
'        strFilePath = ActiveWorkbook.Path & "\DATA" & strFileName
       strFilePath = "C:\ProgramData\Mitutoyo Surftest\SJ-400\" & strFileName
       
       Open strFilePath For Input As #1
           Do While Not EOF(1)
               intJ = intJ + 1
               Line Input #1, strData
               Worksheets("DATA").Cells(intJ, intRow) = strData
           Loop
           intJ = 0
       Close #1
   Next intI
   Exit Sub

ErrHand:
           msg2 = Sheets("Language").Range("A36").Value
           msgtitle2 = Sheets("Language").Range("A37").Value
           MsgBox strFilePath & msg2, vbCritical, msgtitle2
           Application.Cursor = xlDefault
           End
'            End If
'        End If

End Sub

'*****************************************************
'   —ñ‚Ì‘}“ü‚·‚éi‹¤’ʁj
'*****************************************************
Public Sub ROW_INSERTION()
   Worksheets("DATA").Select
   Columns("C:C").Select
   Range("C2").Activate
   Selection.Insert Shift:=xlToRight
   Columns("E:E").Select
   Range("E2").Activate
   Selection.Insert Shift:=xlToRight
End Sub

'*****************************************************
'   ‘ª’èŠÔŠu‚ð‹‚ß‚éi‹¤’ʁj
'*****************************************************
Public Sub MEASUREMENT_PITCH()
   Dim intI        As Integer
   Dim logPIT      As Long
   Dim logLNG      As Long
   Dim logPITCH    As Long
   Dim logLENGTH   As Long
   Dim strUNIT     As String
     
   '’PˆÊ‚ÅŒ…”‚Ì’²®‚ð‚·‚é
   strUNIT = Trim(Mid(Worksheets("DATA").Cells(8, 2), 5))
   If strUNIT = "1" Then
       logPIT = 100
       logLNG = 100000
   ElseIf strUNIT = "2" Then
       logPIT = 10
       logLNG = 10000000
   End If
   
   '»ÝÌßØݸÞË߯Á‚ð‹‚ß‚é
   logPITCH = Val(Mid(Worksheets("DATA").Cells(7, 2), 5)) * logPIT
   '‘ª’è‹Èü
   For intI = 1 To Worksheets("DATA").Range("D1").End(xlDown).Row
       logLENGTH = logLENGTH + logPITCH
       Worksheets("DATA").Cells(intI, 3) = (logLENGTH / logLNG)
  Next intI
   '‘e‚³‹Èü
   logLENGTH = 0
   For intI = 1 To Worksheets("DATA").Range("F1").End(xlDown).Row
       logLENGTH = logLENGTH + logPITCH
       Worksheets("DATA").Cells(intI, 5) = (logLENGTH / logLNG)
   Next intI
End Sub

'*****************************************************
'   ÃÞ°À°¼°Ä¸Ø±°i‹¤’ʁj
'*****************************************************
Public Sub DATASHEET_CLEAR()
  Worksheets("DATA").Cells.ClearContents
End Sub

'*****************************************************
'  ƒOƒ‰ƒtƒXƒpƒ‰ƒ[ƒ^“ü—́i‹¤’ʁj
'*****************************************************
Public Sub CHART_PARAMETER()
   Dim intDROW     As Integer
   Dim dblLENG     As Double
   Dim strCDROW    As String
   Dim strProfile  As String
   Dim mychart
   Dim prof
   '‘ª’è‹Èü
       intDROW = Worksheets("DATA").Range("D1").End(xlDown).Row
       strCDROW = "C1:D" & Trim(intDROW)
           Set mychart = ActiveSheet.ChartObjects("chart 32")
           mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       dblLENG = Worksheets("DATA").Range("C" & intDROW)
       With mychart.Chart _
           .Axes(xlCategory)
           .MinimumScale = 0
           .MaximumScale = dblLENG
       End With
       Call XAXIS_KETA(dblLENG, mychart)

   '•]‰¿‹Èü
       intDROW = Worksheets("DATA").Range("F1").End(xlDown).Row
       strCDROW = "E1:F" & Trim(intDROW)
           Set mychart = ActiveSheet.ChartObjects("chart 33")
           mychart.Chart.SetSourceData Sheets("DATA").Range(strCDROW), xlColumns
       dblLENG = Worksheets("DATA").Range("E" & intDROW)
       With mychart.Chart _
           .Axes(xlCategory)
           .MinimumScale = 0
           .MaximumScale = dblLENG
       End With
       '•]‰¿‹Èü–¼Ì
       strProfile = Trim(Mid(Worksheets("DATA").Cells(3, 2), 4))
       If strProfile = "MOTIF" Then
           strProfile = "P"
       End If
                       prof = Sheets("Language").Range("A58").Value
                       mychart.Chart.ChartWizard Title:=strProfile & prof
       Call XAXIS_KETA(dblLENG, mychart)

   Worksheets("Certificate").Range("A1").Select
End Sub

'*****************************************************
'  ƒ`ƒƒ[ƒg‚ÌXŽ²‚ÌŒ…‚𒲐®‚·‚éi‹¤’ʁj
'*****************************************************
Public Sub XAXIS_KETA(dblLENG, mychart)
   
   If dblLENG < 0.05 Then
           mychart.Chart.Axes(xlCategory).TickLabels.NumberFormat = "0.000_ "
   ElseIf dblLENG >= 0.05 And dblLENG < 1 Then
           mychart.Chart.Axes(xlCategory).TickLabels.NumberFormat = "0.00_ "
   ElseIf dblLENG >= 1 Then
           mychart.Chart.Axes(xlCategory).TickLabels.NumberFormat = "0.0_ "
   End If
End Sub

'*****************************************************
'  ƒ`ƒƒ[ƒg‚Ì’PˆÊ‚ðinch‚ɐ؂è‘Ö‚¦‚éi‹¤’ʁj
'*****************************************************
Public Sub UNIT_INCH()
   Dim mychart
       Set mychart = ActiveSheet.ChartObjects("chart 32")
           mychart.Chart.ChartWizard _
           categorytitle:="[inch]", _
           valuetitle:="[uinch]"
   
       Set mychart = ActiveSheet.ChartObjects("chart 33")
           mychart.Chart.ChartWizard _
           categorytitle:="[inch]", _
           valuetitle:="[uinch]"
         
End Sub

'*****************************************************
'  ƒ`ƒƒ[ƒg‚Ì’PˆÊ‚ðmm‚ɐ؂è‘Ö‚¦‚éi‹¤’ʁj
'*****************************************************
Public Sub UNIT_MM()
   Dim mychart
       Set mychart = ActiveSheet.ChartObjects("chart 32")
           mychart.Chart.ChartWizard _
           categorytitle:="[mm]", _
           valuetitle:="[um]"
           
   
       Set mychart = ActiveSheet.ChartObjects("chart 33")
           mychart.Chart.ChartWizard _
           categorytitle:="[mm]", _
           valuetitle:="[um]"
   
End Sub

'*****************************************************
'  I—¹i‹¤’ʁj
'*****************************************************
Sub syuryo()
   End
   
End Sub


'***************************@‚±‚±‚܂Ł@‹¤’ʁ@**************************






'*****************************************************
'   ‘ª’èðŒ“\‚è•t‚¯i‹@Žíê—pSJ401j
'*****************************************************
Public Sub CONDTION_STICK()
   '‹KŠi
   Worksheets("Certificate").Cells(47, 3) = Trim(Mid(Worksheets("DATA").Cells(5, 2), 4))
   '‹Èü
   Worksheets("Certificate").Cells(48, 3) = Trim(Mid(Worksheets("DATA").Cells(3, 2), 4))
   'ƒŒƒ“ƒW
   Worksheets("Certificate").Cells(49, 3) = Trim(Mid(Worksheets("DATA").Cells(6, 2), 4))
   '‹æŠÖ”@‘ª’è’·‚³
   Worksheets("Certificate").Cells(47, 5) = Trim(Mid(Worksheets("DATA").Cells(2, 2), 4))
   '‹æŠÔ•\‹L
       If Trim(Left(Worksheets("DATA").Cells(2, 2), 1)) = "L" Then
            Worksheets("Certificate").Cells(47, 4) = Sheets("Language").Range("A41").Value '"•]‰¿’·‚³"
        Else
            Worksheets("Certificate").Cells(47, 4) = "N"
        End If
   '‹Èü‚É‚æ‚é•\‹L
       If Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "R MOTIF" Or _
          Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "W MOTIF" Then
           Worksheets("Certificate").Cells(47, 4) = Sheets("Language").Range("A41").Value '"•]‰¿’·‚³"
           Worksheets("Certificate").Cells(48, 4) = "A"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 4))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       ElseIf Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "P" And Trim(Left(Worksheets("DATA").Cells(2, 2), 1)) <> "L" Then
           Worksheets("Certificate").Cells(48, 4) = "L"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 4))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       ElseIf Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "W" Then
           Worksheets("Certificate").Cells(48, 4) = "fh-ƒÉf/fl"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 10))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       Else
           Worksheets("Certificate").Cells(48, 4) = Sheets("Language").Range("A44").Value '"ƒJƒbƒgƒIƒt"
           Worksheets("Certificate").Cells(48, 5) = Trim(Mid(Worksheets("DATA").Cells(1, 2), 4))
           Worksheets("Certificate").Cells(49, 4) = Sheets("Language").Range("A61").Value '"ƒtƒBƒ‹ƒ^"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       End If
       If Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "W MOTIF" Then
           Worksheets("Certificate").Cells(49, 4) = "B"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(10, 2), 4))
       End If
       If Trim(Mid(Worksheets("DATA").Cells(3, 2), 4)) = "R MOTIF" Then
           Worksheets("Certificate").Cells(49, 4) = "ANX"
           Worksheets("Certificate").Cells(49, 5) = Trim(Mid(Worksheets("DATA").Cells(4, 2), 4))
       End If
End Sub

'*****************************************************
'   ÃÞ°À“ǍžÀÞ²±Û¸Þ•\Ž¦i‹@Žíê—pSJ401j
'*****************************************************
Public Sub CommandButton1_Click()
   '•Ï”éŒ¾
   Dim strSurfPath As String
   word = Sheets("ej").Range("a1").Value
   
       If word = "eng" Then
           strSurfPath = ActiveWorkbook.Path & "\Surftest SJ400.exe"
       Else
           If word = "jpn" Then
           strSurfPath = ActiveWorkbook.Path & "\Surftest SJ400.exe"
           End If
       End If
   
   
   'AP‹N“®
   Shell strSurfPath, vbNormalFocus
End Sub

'*****************************************************
'   ‰‰ŽZŒ‹‰Ê“\‚è•t‚¯i‹@Žíê—pSJ300/400j
'*****************************************************
Public Sub RESULT_STICK()
   Dim intI       As Integer
   Dim intComp    As Integer
   Dim strPar     As String
   
'    For intI = 1 To 24
'        If intI <= 12 Then
'            Worksheets("Certificate").Cells(51 + intI, 2) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
'            Worksheets("Certificate").Cells(51 + intI, 3) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
'        Else
'            Worksheets("Certificate").Cells(51 + intI - 12, 4) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
'            Worksheets("Certificate").Cells(51 + intI - 12, 5) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
'        End If
'    Next intI

 
   For intI = 1 To 24
       If intI <= 12 Then
           'ƒpƒ‰ƒ[ƒ^–¼
           strPar = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           'Rz1maxƒpƒ‰ƒ[ƒ^‚ªRz1m‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×AŒã‚Ìax‚ð’ljÁ‚µ‚ĕ₤
           If InStr(strPar, "z1m") > 0 Then strPar = strPar & "ax"
           'Rmr(c)ƒpƒ‰ƒ[ƒ^‚ªRmrc‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×ARmr(c)‘‚«Š·‚¦‚é
           If InStr(strPar, "mrc") > 0 Then strPar = Left(strPar, 1) & "mr(c)"
           Worksheets("Certificate").Cells(51 + intI, 2) = strPar
           'Worksheets("Certificate").Cells(51 + intI, 2) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           Worksheets("Certificate").Cells(51 + intI, 3) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
       Else
           'ƒpƒ‰ƒ[ƒ^–¼
           strPar = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           'Rz1maxƒpƒ‰ƒ[ƒ^‚ªRz1m‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×AŒã‚Ìax‚ð’ljÁ‚µ‚ĕ₤
           If InStr(strPar, "z1m") > 0 Then strPar = strPar & "ax"
           'Rmr(c)ƒpƒ‰ƒ[ƒ^‚ªRmrc‚µ‚©‘—M‚³‚ê‚È‚¢ˆ×ARmr(c)‘‚«Š·‚¦‚é
           If InStr(strPar, "mrc") > 0 Then strPar = Left(strPar, 1) & "mr(c)"
           Worksheets("Certificate").Cells(51 + intI - 12, 4) = strPar
           'Worksheets("Certificate").Cells(51 + intI - 12, 4) = Trim(Left(Worksheets("DATA").Cells(intI, 1), 4))
           Worksheets("Certificate").Cells(51 + intI - 12, 5) = Trim(Mid(Worksheets("DATA").Cells(intI, 1), 5))
       End If
   Next intI



End Sub

'*****************************************************
'   ‰‰ŽZŒ‹‰Ê•\Ž¦íœi‹@Žíê—pSJ300/400j
'*****************************************************
Public Sub RESULT_DELL()
   Worksheets("Certificate").Range("B52:E63").ClearContents
End Sub

[Hagen]

esrtmal vielen Dank an alle. Der Code nochmal in Code. Im Anhang das Komplette. Der erste Laufzeitfehler ist die Verknüpfung zu Surftest, diese kann mann ignorieren weil diese exe bei Euch nicht vorhanden ist. Das Passwort für den VBA Code ist : 1234

Vielen Dank
Gruß Hagen

[RPP63]

Moin!
Nicht schlecht, Herr Specht:

Der erste Laufzeitfehler ist die Verknüpfung zu Surftest, diese kann mann ignorieren weil diese exe bei Euch nicht vorhanden ist.

Du machst mir Spaß!
Warum sollte ich mir ein MB-Monster herunterladen, wenn doch gerade der Shell-Befehl zur nicht vorhandenen .exe Deine Probleme verursacht?
Ich weiß nicht, wie der Ablauf in der .exe ist (sprich: selbstschließend?) und vor allem, warum VBA nicht auf die Beendigung wartet, deshalb ja auch der Tipp in meiner letzten Antwort.

Beim derzeitigen Stand nutzt mir die Datei wenig, aber vielleicht findet ja ein anderer den Stein des Weisen.

[off topic]
imo ist so etwas für einen Dienstleister, der sich die Situation "am offenen Herzen" anschauen kann.
[/off topic]

Gruß Ralf