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 質問
【36970】Re:助けてください・・・・・ Jaka 06/4/19(水) 11:10 発言
【36972】Re:助けてください・・・・・ (注意) 06/4/19(水) 11:17 発言
【36985】Re:助けてください・・・・・ Kein 06/4/19(水) 13:19 回答

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