| |
Sub 本物()
ブック名 = InputBox("図形を検索したいブック名を入れてください")
Workbooks(ブック名 & ".xls").Activate
Dim シート番号 As Integer
シート番号 = InputBox("図形を検索したいシートの番号を入れてください。'左から1番目'")
ActiveWorkbook.Worksheets(シート番号).Activate
名前 = InputBox("図面収集する最初の材料コードを入力してください 例:***-****", vbRetryCancel)
ActiveSheet.Range("C1:C65536").Find(what:=名前).Select
Dim R As Range
Dim MyR As Range
Set MyR = Range("C1", Range("C65536").End(xlUp))
For Each R In MyR
'If1 セルが空セルだ
If Selection.Value = "" Then
'If2 セル結合されてる
If Selection.MergeCells Then
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'Else2 セル結合されていない
Else
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'End2 If
End If
'ElseIf1 セルが空セルでない
ElseIf Selection.Value <> "" Then
'新しいファイル名の作成
bb = Selection.Offset(0, "-1").Value
Select Case bb
Case "A", "B", "C", "D", "E", "F", "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
'IF3 検索してセルと同じ名前のフォルダがある
製番1 = ActiveWorkbook.Name
Dim 検索1 As String
検索1 = Dir("C:\Documents and Settings\ゆみ\デスクトップ\" & 製番1 & ActiveSheet.Name, Attributes:=vbDirectory)
If 検索1 = 製番1 & ActiveSheet.Name Then
'If4 検索してセルと同じ名前のファイルがある
Dim Uppercase, LowerCase
Uppercase = Selection.Value
LowerCase = LCase(Uppercase)
Dim 検索11 As String
検索11 = Dir("c:\加工図\" & Selection.Value & ".dwg", Attributes:=vbNormal)
If 検索11 = LowerCase & ".dwg" Then
'○ファイル元からコピーして所定の場所に保存
Dim ファイル変更1 As New FileSystemObject
ファイル変更1.CopyFile "c:\加工図\" & Selection.Value & ".dwg", _
"c:\documents and settings\ゆみ\デスクトップ\" & 製番1 & ActiveSheet.Name _
& "\" & 番号 & 材料名 & "×" & サイズ & "×" & 長さ & "-" & 数量 & "s.dwg"
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'ElseIf4 検索してセルと同じ名前のファイルがない
ElseIf 検索11 <> LowerCase & ".dwg" Then
'○セルにいろをつける
Selection.Interior.Color = RGB(255, 255, 0)
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'End4 if
End If
'ElseIF3 検索してセルと同じ名前のフォルダがない
ElseIf 検索1 <> 製番1 & ActiveSheet.Name Then
'○フォルダの作成
Call フォルダの作成1
'If5 検索してセルと同じ名前のファイルがある
Up = Selection.Value
LowerCase = LCase(Up)
Dim 検索12 As String
検索12 = Dir("c:\加工図\" & Selection.Value & ".dwg", Attributes:=vbNormal)
If 検索12 = LowerCase & ".dwg" Then
'○ファイル元からコピーして所定の場所に保存
Dim ファイル変更2 As New FileSystemObject
ファイル変更2.CopyFile "c:\加工図\" & Selection.Value & ".dwg", _
"c:\documents and settings\ゆみ\デスクトップ\" & 製番1 & ActiveSheet.Name _
& "\" & 番号 & 材料名 & "×" & サイズ & "×" & 長さ & "-" & 数量 & "s.dwg"
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'ElseIf5 検索してセルと同じ名前のファイルがない
ElseIf 検索12 <> LowerCase & ".dwg" Then
'○セルにいろをつける
Selection.Interior.Color = RGB(255, 255, 0)
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'End5 if
End If
'End3 If
End If
'End1 If
End If
Next R
End Sub
Sub フォルダの作成1()
Dim フォルダ作成1 As New FileSystemObject
製番1 = ActiveWorkbook.Name
フォルダ作成1.CreateFolder ("c:\documents and settings\だいすけ\デスクトップ\" & 製番1 & ActiveSheet.Name
*********************************************
ながながとすみません・・・
繰り返ししながら、セルを移動させていきたいのですが、
どうしても、空セルでなおかつ、セルが結合されているとき
に処理がとまってしまいます。
セルに値があり、その時もセルが結合されていたら
ひとつ下のセルを選択といったようにしたいのですが・・・・
明日までにと上司から言われており
ほんとに困ってます
どなたか、お願いしますT T
|
|
ゆみ
- 06/4/20(木) 21:25 -
