| |
ナンか「意味を考えずに継接ぎしただけのコード」に見えますね・・。
基礎から学習しなおさないと、まともなコードは作れませんよ。
いちおう添削しておきます。
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
動作のテストは、こちらで出来るはずも無いのでしていません。
ロジックの考え方も含めて、よくコードを解析してみて下さい。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
