Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

44800 / 76732

←次へ　｜　前へ→


	【36943】助けてください・・・・・

ともこ - 06/4/18(火) 18:09 -


	引用なし

	パスワード

Sub 違うやつ()
Workbooks("明細.xls").Activate
Workbooks("明細.xls").Worksheets(2).Select
Dim myhyperlink As Hyperlink
For Each myhyperlink In ActiveSheet.Hyperlinks
myhyperlink.Delete
Next

Do
名前 = InputBox("図面の必要な材料コードを入力してください例:***-****", vbRetryCancel)
Loop Until 名前 <> ""
ActiveSheet.Range("C1:C600").Find(what:=名前).Select

Do
'新しいファイル名の作成
　　bb = Selection.Offset(0, "-1").Value
　　Select Case bb
Case Is = "A"
番号 = "00" & bb
Case Is = "B"
番号 = "00" & bb
Case Is = "C"
番号 = "00" & bb
Case Is = "D"
番号 = "00" & bb
Case Is = "E"
番号 = "00" & bb
Case Is = "F"
番号 = "00" & bb
Case Is = "G"
番号 = "00" & bb
Case Is >= 10
番号 = "0" & bb
Case Is < 10
番号 = "00" & bb
End Select
　　材料名 = Selection.Offset(0, 1).Value
　　サイズ1 = Selection.Offset(0, 2).Value
　　サイズ2 = Selection.Offset(0, 3).Value
　　サイズ3 = Selection.Offset(0, 4).Value
　　サイズ = サイズ1 & サイズ2 & サイズ3
　　長さ1 = Selection.Offset(0, 5).Value
　　長さ2 = Selection.Offset(0, 6).Value
　　長さ3 = Selection.Offset(0, 7).Value
　　長さ = 長さ1 & 長さ2 & 長さ3
　　数量 = Selection.Offset(0, 8).Value

'フォルダの存在1
製番1 = Worksheets(1).Range("B3").Value
　Dim 検索1 As String
　検索1 = Dir("C:\Documents and Settings\mkn\デスクトップ\" & 製番1 & "部材明細表（ヘッド・テール)", Attributes:=vbDirectory)
　

'検索してフォルダがある場合
　　　If 検索1 = 製番1 & ActiveSheet.Name Then
　　　　Dim 検索11 As String
　　　　検索11 = Dir("c:\加工図\" & Selection.Value & ".dwg", Attributes:=vbNormal)
'検索してファイルが指定の場所にある場合
　　　　　　If 検索11 = Selection.Value & ".dwg" Then
　　　　　　　Dim ファイル変更1 As New FileSystemObject
　　　　　　　ファイル変更1.CopyFile "c:\加工図\" & Selection.Value & ".dwg", _
　　　　　　 "c:\documents and settings\mkn\デスクトップ\" & 製番1 & ActiveSheet.Name _
　　　　　　　& "\" & 番号 & 材料名 & "×" & サイズ & "×" & 長さ & "-" & 数量 & "s.dwg"
　'検索してファイルが指定の場所にない場合
　　　　　　ElseIf 検索11 <> Selection.Value & ".dwg" Then
　　　　　　　Selection.Interior.Color = RGB(255, 255, 0)
　　　　　　
　　　　　 End If
'検索してフォルダがない場合
　　　ElseIf 検索1 <> 製番1 & ActiveSheet.Name Then
　　　　Call フォルダの作成1
　　　　Dim ファイル変更2 As New FileSystemObject
　　　　ファイル変更2.CopyFile "c:\加工図\" & Selection.Value & ".dwg", _
　　　　　　 "c:\documents and settings\mkn\デスクトップ\" & 製番1 & ActiveSheet.Name _
　　　　　　　& "\" & 番号 & 材料名 & "×" & サイズ & "×" & 長さ & "-" & 数量 & "s.dwg"
　　　End If
Selection.Offset(1, 0).Select
Loop Until Selection.Value = ""

End Sub

ファイルの検索をかけたのですが、
認識されません・・・・・
どなたか、メールでもいいので教えてください！！

4 hits

▼

【36943】助けてください・・・・・ ともこ 06/4/18(火) 18:09

≪