Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


44759 / 76732 ←次へ | 前へ→

【36985】Re:助けてください・・・・・
回答  Kein  - 06/4/19(水) 13:19 -

引用なし
パスワード
   ナンか「意味を考えずに継接ぎしただけのコード」に見えますね・・。
基礎から学習しなおさないと、まともなコードは作れませんよ。
いちおう添削しておきます。

Sub 違うやつ改()
  Dim MySh As Worksheet
  Dim FR As Range
  Dim Nm As String, No As String, Fol As String
  Dim Fil As String, NewF As String
  Dim 材料名 As String, サイズ As String, 長さ As String
  Dim bb As Variant, 数量 As Variant, 製番 As Variant
  Const Ph As String = _
  "C:\Documents and Settings\mkn\デスクトップ\"

  On Error Resume Next
  Set MySh = Workbooks("明細.xls").Worksheets(2)
  If Err.Number <> 0 Then
   Workbooks.Open ThisWorkbook.Path & "\明細.xls"
   Set MySh = ActiveWorkbook.Worksheets(2)
   Err.Clear
  End If
  On Error GoTo 0
  Nm = InputBox("図面の必要な材料コードを入力してください 例:***-****")
  If Nm = "" Then GoTo ELine
  Set FR = MySh.Range("C1:C600").Find(Nm, , xlValues)
  If FR Is Nothing Then
   MsgBox Nm & vbLf & "は見つかりません。", 48
   GoTo ELine
  End If
  With MySh.Hyperlinks
   If .Count > 0 Then .Delete
  End With
  Do
   bb = FR.Offset(, -1).Value
   If VarType(bb) = 8 Then
     Select Case bb
      Case "A", "B", "C", "D", "E", "F", "G"
        No = "00" & bb
      Case Else
        GoTo ELine
     End Select
   ElseIf VarType(bb) = 2 Or VarType(bb) = 3 Then
     Select Case bb
      Case Is < 10
        No = "00" & bb
      Case Is >= 10
        No = "0" & bb
     End Select
   Else
     GoTo ELine
   End If
   材料名 = FR.Offset(, 1).Value
   サイズ = FR.Offset(, 2).Value & FR.Offset(, 3).Value & _
   FR.Offset(, 4).Value
   長さ = FR.Offset(, 5).Value & FR.Offset(, 6).Value & _
   FR.Offset(, 7).Value
   数量 = FR.Offset(, 8).Value
   製番 = Workbooks("明細.xls").Worksheets(1).Range("B3").Value
   Fol = Dir(Ph & 製番 & "部材明細表(ヘッド・テール)", 16)
   NewF = 製番 & MySh.Name & "\" & No & 材料名 & "×" & サイズ & _
   "×" & 長さ & "-" & 数量 & "s.dwg"
   If Fol <> "" Then
     Fil = Dir("C:\加工図\" & FR.Value & ".dwg", 0)
     If Fil <> "" Then
      FileCopy "C:\加工図\" & Fil, Ph & NewF
     Else
      FR.Interior.Color = RGB(255, 255, 0)
     End If
   Else
     Call フォルダの作成1
     FileCopy "C:\加工図\" & FR.Value & ".dwg", Ph & NewF
   End If
   Set FR = FR.Offset(1)
  Loop Until FR.Value = ""
  Set FR = Nothing
ELine:
  Set MySh = Nothing
End Sub

動作のテストは、こちらで出来るはずも無いのでしていません。
ロジックの考え方も含めて、よくコードを解析してみて下さい。
7 hits

【36943】助けてください・・・・・ ともこ 06/4/18(火) 18:09 質問
【36970】Re:助けてください・・・・・ Jaka 06/4/19(水) 11:10 発言
【36972】Re:助けてください・・・・・ (注意) 06/4/19(水) 11:17 発言
【36985】Re:助けてください・・・・・ Kein 06/4/19(水) 13:19 回答

44759 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free