ＥＸＣＥＬの自動記録の修正の件

質問

いつもお世話になっております。

こんな質問しました。
http://okwave.jp/qa3973267.html
http://okwave.jp/qa3973335.html

なんとか、自動記録とＯＫｗｅｂの受け売りで、
やってみました。
でも、もう限界です。
教えて下さい。

【困っていること】
１．保管するファイル名を固定でなく、
見積書.XLSのH13（固定）の値で、
ファイル名を付けて保存したい。
２．台帳.XLSのT2:AG2のコピー先で、
全てが選択されている状態のため、
リンクが全項目になっている。
先頭の項目だけにしたい。T2のコピー先のみ。
３．リンクを固定でなくて、
ファイル名、表示名をT2（固定）の値、
もしくはコピー先（可変）の値でしたい。
今は、見積書.XLSとSEC01-20080001となっているのを、
可変に、例、SEC01-20080100.XLSとSEC01-20080100にしたい。

現在のコード（一部）は以下です。

Range("A1").Select
ChDir "H:\2008\見積"
ActiveWorkbook.SaveAs Filename:= _
"H:\2008\見積\見積書.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Windows("台帳.xls").Activate
Range("T4").Select
Selection.Copy
Range("T2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("S3").Select
Application.CutCopyMode = False
Selection.Copy
Range("S1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("T2:AG2").Select
Application.CutCopyMode = False
Selection.Copy
Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="見積書.xls", _
TextToDisplay:="SEC01-20080001"
Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Offset(1).Select
ActiveWorkbook.Save

宜しくお願い致します。

回答No.1

end-u · ベストアンサー

こんにちは。

"H:\2008\見積\見積書.xls"の標準モジュールに、下記マクロを置いて使います。
仕様は、ご提示のコードに沿っていますが、

"H:\2008\見積\見積書.xls"の●●●シートのH14セルの値を参照して、
"H:\2008\見積\見積書.xls"を別の名前で保存する。

"台帳.xls"の■■■シートのデータコピー処理をして、
最終行に追加したデータのD列に Hyperlink を設定する。
この時、リンク先は"H:\2008\見積\"フォルダの、Hyperlink を設定したセルの値。

...といった感じでしょうか。違う場合は修正してください。
マクロの動きは、[F8]キーを押してステップ実行しながら確認してみてください。

Sub try()
　　Dim r　As Range　'Hyperlinkセットするセルを入れるRange型変数を準備しておきます。

　　'ThisWorkbookとはこのマクロの保存先。最初は"H:\2008\見積\見積書.xls"の事です。
　　'シート名の記載がなく、不明です。●●●を実際のシート名に変更してください。
　　With ThisWorkbook
　　　　.SaveAs Filename:="H:\2008\見積\" & .Sheets("●●●").Range("H14").Value
　　End With

　　'以下は"台帳.xls"に対しての処理。■■■を実際のシート名に変更してください。
　　With Workbooks("台帳.xls")
　　　　With .Sheets("■■■")
　　　　　　.Range("T2").Value = .Range("T4").Value
　　　　　　.Range("S1").Value = .Range("S3").Value
　　　　　　Set r = .Cells(.Rows.Count, 4).End(xlUp).Offset(1)
　　　　　　r.Resize(, 14).Value = .Range("T2:AG2").Value
　　　　　　.Hyperlinks.Add Anchor:=r, _
　　　　　　　　　　　　　　Address:="H:\2008\見積\" & r.Value & ".xls"
　　　　End With
　　　　.Save
　　End With

　　Set r = Nothing
End Sub