Excel VBA質問箱 IV

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

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


7772 / 13645 ツリー ←次へ | 前へ→

【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 回答[未読]

【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

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

【36970】Re:助けてください・・・・・
発言  Jaka  - 06/4/19(水) 11:10 -

引用なし
パスワード
   ぱっと見ただけなのでよく解ってませんけど。

>ActiveSheet.Range("C1:C600").Find(what:=名前).Select
   ↓
Dim MyRag As Range
Set MyRag = ActiveSheet.Range("C1:C600").Find(what:=名前)
If MyRag Is Nothing Then
  MsgBox "NG"
  'Exit Sub '← 一応コメントにしました。
End If

>bb = Selection.Offset(0, "-1").Value
  以降↓こう書けます。
bb = MyRag.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
  ↓
番号 = String(3 - Len(bb), "0") & bb

>検索1 = Dir("C:\Documents and Settings\mkn\デスクトップ\" & 製番1 & "部材明細表(ヘッド・テール)",

Attributes:=vbDirectory)
この「wkn」ってなんですか?
変数なら、こうしないとまずいんじゃないですか?
"C:\Documents and Settings\" & mkn & "\デスクトップ\"

因みにログインした人のデスクトップなら
CreateObject("WScript.Shell").SpecialFolders("Desktop")
で、取れます。
また、パス、ファイルフルネームは、1度変数に入れた方が見やすいかも....。

因みに
97だと、CopyFileは動かないし、As New FileSystemObject ってやった事ないので解りません。

【36972】Re:助けてください・・・・・
発言  (注意)  - 06/4/19(水) 11:17 -

引用なし
パスワード
   本サイトの基本方針をまとめました。こちら をご一読ください。
>タイトルは内容を示すものに
>記事のタイトルは、その質問の内容が端的にわかるようなものにしてください。
>単に「教えてください」とか「困っています」などといったタイトルでは、回答
>者があなたの質問をクリックしない可能性が非常に高くなります。すなわち、回
>答がつかない可能性が高くなる、ということです。

【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

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

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