[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『自動的にリンクさせたい』（sakura）
いつもお世話になっております。
見積書を作成（会社ごとに別BOOK）していて、それぞれに見積番号がついています。 見積書は、複数人が作成します。
＜見積書＞（だいぶ端折っていますが・・）
A B C D
1 客先 番号
2 あいう 111
3 見積金額
4 \1,000,000
5 現場
6 大阪
7 内容
8 製作
また、別bookに下記のような一覧表を作成していて、見積もり番号順に並んでいます。
＜見積一覧表＞
A B C D E
1 番号 現場名 客先 内容 見積金額
2 111 大阪 あいう 製作 \1,000,000
3 112 東京 かきく 作業 \2,000,000
4 113 名古屋 さしす 取付 \3,000,000
5 114 福岡 たちつ 作業 \1,000,000
6 115 兵庫 なにぬ 製作 \2,000,000
今は、まず「見積もり一覧表」をみて、続き番号を確認してから見積書を作成して います。作成が終わったら、一つ一つリンク貼り付けしています。
したいことは・・・ ＜見積書＞を開いたら、＜見積一覧表＞の次の番号が入力されていて、作成後、 保存したら（保存場所は、みんな同じ場所に保存します）自動的に＜見積一覧表＞に 内容をリンクさせたいのです。 そして＜見積一覧表＞の例えば「客先名」をクリックすると、 その見積書を開く事が出来るようにしたいです。
関数では、無理ですよね？ マクロは、今まで使ったことが無いのですが勉強したいと思っていますので、 よろしくお願い致します。
windows7 excel2010
>見積書を開いたら
というのは、新規で見積書を作成する場合の、雛形のようなブック？ もし、既存の見積書ブックなら、すでに一覧表に存在するはずだよね？
で、見積書を作成し終わったとして、どんなタイミングで保存（かつ、一覧表に追加）する予定？
それと、各見積書ブックのブック名のルールは？
(ぶらっと)
ぶらっと様
コメント、ありがとうございます。 もう付かないのかと思ってましたが、私の書き方が悪かったのですね。 すみません。
まず、
＞新規で見積書を作成する場合の、雛形のようなブック？
そうです。
雛形があって、それを使って各人が見積書を作成していきます。
で、会社別にフォルダが作ってあって、そこに名前を付けて保存しています。
（スミマセン、質問で”会社別BOOK”と書いてしまいました。フォルダの間違いです）
なので、雛形は、そのまま原本として残ります。
＞見積書を作成し終わったとして、どんなタイミングで保存（かつ、一覧表に追加）する予定？
見積書を会社別BOOKに保存した時点で、一覧表の最後の（続きの？）番号のところに
追加していきたいのです。
一覧表には、あらかじめ続き番号が入力されていて、そのほかのセルは空欄になっています。
＞各見積書ブックのブック名のルールは？
「ブック名のルール」というのは、どういうことですか？
（理解力がなくてスミマセン(T_T)）
とりあえず、今の保存状態を書きますね。
雛形見積書を使って作成（ここで一覧表をみて次の見積もり番号を確認） → 保存名は「現場名」で、 会社別フォルダに保存 → 一覧表にリンク貼り付け
としています。
sakura
>「ブック名のルール」というのは、どういうことですか？
たとえば 出来上がった見積書を あいう.xls という名前にすると具合悪いよね？ 同じ客先で１つしか保存できなくなるので。
実際の見積書ブックは、たぶん、あいう_●●●_□□□.xls といった名前にしているんだろうとおもうけど その名前の付け方のルールを教えてほしいという意味。
(ぶらっと)
ぶらっと様
あ、そういうことですね。
保存している名前は「会社名 現場名」という風に保存しています。 そして、各会社のフォルダに保存しています。 このフォルダは共有フォルダです。
よろしくお願いします。
sakura
ところで、その【会社別フォルダ】のフォルダパスは、どうやって把握したらいいのかな？
たとえば あいう会社のフォルダは、どこに、どんな名前で存在するのかな？
もう１つ。 様々なＰＣで、同時にこの処理を行う必要あり？ つまり、一覧表は共通フォルダに１つあるわけで、同時に複数のＰＣからアクセスした場合 見積書番号が同じになるリスクがあるので。 どこかで見積書作成作業中なら、別のＰＣでは作成不可としていいよね？
(ぶらっと)
度々スミマセン。
フォルダパス（？）
\\LS-VL5BD\share\見積書\25年度
↑これでしょうか？
また、どこかで見積書作成作業中なら、別のＰＣでは作成不可です。
sakura
>\\LS-VL5BD\share\見積書\25年度
会社毎に別フォルダじゃなかった？
(ぶらっと)
おはようございます。
返信が遅れて申し訳ありません。
>\\LS-VL5BD\share\見積書\25年度 の中に会社別にフォルダを作っています。
フォルダ名は会社名をつけています。
例えば、「あいう」という会社の「大阪」の現場の見積もりを保存する場合、
\\LS-VL5BD\share\見積書\25年度\あいう に、「あいう 大阪」という名でbookを保存しています。
sakura
>\\LS-VL5BD\share\見積書\25年度\あいう >に、「あいう 大阪」という名でbookを保存しています。
了解。すこし時間ください。
(ぶらっと)
すみません。
宜しくお願い致します。
sakura
＞excel2010 と言う事なので、ちょっと不安がありますが もしかしたら「データ追跡機能付きテンプレートウィザード」が使えるかもしれないですね。
ぶらっとさんから、コード(or仕組み)の追加書き込みが 有るんじゃないかとは思いますが。。。？
(HANA)
ちょっと覗いてみたら、私が関与してて、その関与してたことを、すっかり忘れてた！！！ ごめん！！
ということで、今から思い出してみるけど、HANAさんの指摘、「データ追跡機能付きテンプレートウィザード」 魅力的ですねぇ。このあたり、まったくわからないので、この線で、HANAさんから回答ああればうれしいですねぇ。
(ぶらっと)
To,ぶらっとさん ＞ちょっと覗いてみたら、私が関与してて、その関与してたことを、すっかり忘れてた！！！ 昨日・一昨日とレスがつかなかったので、そんな所だろうと思って、あげてみました。
「データ追跡機能付き〜」はいつまで使えるかわからないので。。。 http://www4.synapse.ne.jp/yone/excel2010/excel2010_tuisekil.html
(HANA)
To HANA さん
>そんな所だろうと思って、あげてみました
はい。ありがとうございます。
To sakuraさん
忘れていたうえに、今、風邪気味で強烈な咳がでていて、頭朦朧。 しばらく、まともな思考回路が働かないと思うので、別の回答者さんに 大いに期待してほしいな。
(ぶらっと)
sakuraさん、回答でなくて、すみません。ちょっと、ぶらっとさんが心配になっちゃったので、少しだけ、 スペースをお借りさせてください m(__)m
To ぶらっとさん 昨日、今朝とおみかけしなかったので、お忙しいのかなと思ってました。 しばらく、ぶらっとさん節が聞けなくて寂しいですが^^; どうか、どうか、お体ご自愛ください。 回復されたら、またいろんな回答を見せてくださいね。お大事にどうぞ。
(usamiyu)
いえいえ(~_~;)
こちらこそ、体調がすぐれないところコメント頂いて申し訳ありません。
あれから、自分でももっと勉強しようと奮闘しています！
また是非、体調が万全になりましたら、お願い致します。
（あ、催促とかではないのですよ(~_~;)）
どうぞ、お大事になさって下さいね。
ありがとうございました。
HANA様
コメントありがとうございます。
「データ追跡機能付きテンプレートウィザード」
そんな機能があるのですね？！
これから勉強します。
ありがとうございました。
usamiyu様
どうぞ、どうぞ。
これからも、質問させていただくかもしれませんので、
その際にはよろしくお願い致します（笑
sakura
うまく動くかどうかわかりませんが。。。
「\\LS-VL5BD\share\見積書\25年度」の中に 見積書.xls と、見積一覧表.xls を置いて下さい。
で、レイアウトは当初ご提示の物で 見積一覧表は、F列：登録日、G列：保存場所 を増やしています。 ハイパーリンクは、A列につけています。（関数ですが。。。）
どの様に成っているのが良いのか分からないですが 「修正」が簡単に成る様に、一覧表へは リンクで表示しています。 入力が無いセルをリンクするとセルには「0」が表示されるので 何らかの対処が必要になるかもしれません。
また、開くと更新されるので閉じる際に「保存しますか？」 なんて聞かれるかもしれません。 煩わしければ、値を転記する様にした方が良いかもしれません。
ブック名は、現場名だけだと重複する事もあるかもしれないので その後ろに番号もつけて保存する事にしています。
以下のコードは、見積書.xls の標準モジュールに貼り付けてください。 番号は、登録するタイミングで取得します。 番号以外を入力後、登録マクロを実行して下さい。
'------
Sub 登録()
'=======================================
'ここに載せていたコードは、削除しました。
'↓に変更後のものを再UPします。 6/25
'=======================================
End Sub
'------
(HANA)
↑で一度コードをUPしましたが、忘れてたものがあったので 追加して再UPします。
シートの方の追加説明ですが、見積書ブックに オートシェイプを一つ置いて、テキストの編集(X)で「登録」と記入して下さい。 そのオートシェイプに、右クリック→マクロの登録(N) で、マクロを登録して下さい。
以下、変更後のコードです。
'------
Sub 登録1()
Dim msg As String
Dim MyPath As String, MyBkN As String, MyShN As String
Dim BkIPath As String, LinkStr As String
Dim mxR As Long, MyN As Long
Dim dt As Variant, RngA As Variant
Dim BkI As Workbook
Dim shp As Object
RngA = Array("D2", "A6", "A2", "A8", "A4")
'番号,現場名,客先,内容,見積金額
'番号未入力確認
If Range(RngA(0)).Value <> "" Then
If MsgBox("番号が入力済みです。" & vbLf & _
"新しく番号を取得して登録しますか？", vbOKCancel) = vbCancel Then
Exit Sub
End If
End If
'必須項目入力確認
If Range(RngA(2)).Value = "" Then msg = msg & vbLf & vbTab & "客先"
If Range(RngA(1)).Value = "" Then msg = msg & vbLf & vbTab & "現場"
If Len(msg) > 0 Then
MsgBox "以下の項目が未入力です。" & msg & vbLf & _
"登録を中止します。"
Exit Sub
End If
'フォルダ存在確認
MyPath = ThisWorkbook.Path & "\" & Range(RngA(2)).Value
If Dir(MyPath, vbDirectory) = "" Then
MkDir MyPath
End If
'見積一覧表を開く
BkIPath = ThisWorkbook.Path & "\" & "見積一覧表.xls"
On Error Resume Next
Err.Clear
Open BkIPath For Append As #1
Close #1
If Err.Number > 0 Then
MsgBox "見積一覧表は開かれています。" & vbLf & _
"しばらくしてもう一度登録して下さい。"
Exit Sub
Else
Set BkI = Workbooks.Open(BkIPath)
End If
On Error GoTo 0
'最終行・番号取得
mxR = BkI.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
MyN = BkI.Application.Max(Sheets(1).Range("A1:A" & mxR)) + 1
'見積書保存
ThisWorkbook.Worksheets(1).Copy
For Each shp In ActiveSheet.Shapes
If shp.TextFrame.Characters.Text = "登録" Then
shp.Delete
End If
Next
Range(RngA(0)).Value = MyN
MyBkN = Range(RngA(1)).Value & "_" & MyN & ".xls"
MyShN = Sheets(1).Name
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=MyPath & "\" & MyBkN, FileFormat:=xlExcel8
ActiveWindow.Close
Application.DisplayAlerts = True
'一覧表作成
ReDim dt(1 To 1, 1 To 7)
LinkStr = "='" & MyPath & "\[" & MyBkN & "]" & MyShN & "'!"
dt(1, 1) = "=HYPERLINK(G" & mxR + 1 & "," & MyN & ")"
dt(1, 2) = LinkStr & RngA(1)
dt(1, 3) = LinkStr & RngA(2)
dt(1, 4) = LinkStr & RngA(3)
dt(1, 5) = LinkStr & RngA(4)
dt(1, 6) = Date
dt(1, 7) = MyPath & "\" & MyBkN
BkI.Sheets(1).Range("A" & mxR + 1).Resize(, 7).Value = dt
Application.DisplayAlerts = False
BkI.Save
BkI.Close
Application.DisplayAlerts = True
Set BkI = Nothing
'転記終了
Range(Join(RngA, ",")).ClearContents
ThisWorkbook.Saved = True
MsgBox MyPath & " に" & vbLf & _
MyBkN & " で保存しました。" & vbLf & _
"番号は " & MyN & " です。"
End Sub
'------
(HANA)
おはようございます。
凄いです！ありがとうございます！
さっそく会社でやってみます。
（取り急ぎお礼まで）
マクロは初めてなので、また質問させていただくかもしれませんが
その際は、よろしくお願い致します。
sakura
何度もすみません。
教えていただいたまくろですが、
If shp.TextFrame.Characters.Text = "登録" Then
↑ここが黄色くなって
「実行時エラー４３８
オブジェクトは、このプロパティ
またはメゾッドをサポートしていません」
と、メッセージがでます。
自分で何とかしようと思ったのですが、わかりませんでした。
よろしくお願い致します。
sakura
あ〜、なんですかねぇ。 こちらでは動くのですが。。。
オートシェイプはいくつかありますか？
試しにこんなのを動かしてもらうと。。。
Sub test()
Dim shp As Object
For Each shp In ActiveSheet.Shapes
MsgBox shp.Name
If shp.TextFrame.Characters.Text = "登録" Then
' shp.Delete
End If
Next
End Sub
図形がいくつかある場合、図形名がどんどん表示されますが
[OK]を押した後にエラーになった時の図形名が何に成っているか
教えてもらえますか？
ちなみに、どの図形を描きましたか？
(HANA)
コメントありがとうございます。
OKを押した後「picture38」と表示されました。
図形は「角丸四角形」です。
あ、図形選択がまずかったんですか？
追記＞オートシェイブは、いくつかありますが
作った人が今はいないので、どれを使ったのかわからないんです。
okを押した後は、一回だけ図形名が出ました。
sakura
「picture38」 って事は、写真（画像の挿入）がありますか？
こんなのだと、どうなりますか？
Sub test2()
Dim shp As Object
MsgBox "図形は " & ActiveSheet.Shapes.Count & " 個あります。"
For Each shp In ActiveSheet.Shapes
If shp.Type <> msoPicture Then
If shp.TextFrame.Characters.Text = "登録" Then
MsgBox shp.Name & "は、マクロ実行ボタンです。"
' shp.Delete
Else
MsgBox shp.Name & "は、その他のシェイプです。"
End If
Else
MsgBox shp.Name & "は、写真です。"
shp.Select
End If
Next
End Sub
コードはマクロ実行ボタンを見つけられますか？ 図形の数等 は認識している数と一致しますか？
＞オートシェイブは、いくつかありますが ってのは、シート上に既にいくつか配置されている って事ですよね？
(HANA)
＞写真（画像の挿入）がありますか？
→あります。
見積書の雛形には、既に「会社のロゴマーク」「会社印」×２と
テキストボックスが、配置されています。
＞コードはマクロ実行ボタンを見つけられますか？
＞図形の数等 は認識している数と一致しますか？
→教えていただいたマクロを実行すると
「図形は5個あります」
「picture38は写真です」
「TextBox35は、その他のシェイブです」
「picture1は写真です」
「picture35は写真です」
「Rounded Rectangleは、その他のシェイブです」
と表示されました。
図形は、マクロ実行ボタンを入れて、５つなので、この中に
マクロボタンも入っていると思いますが、どれなのかが
解らないです。
よろしくお願いします。
sakura
これまでのご説明からすると ＞「Rounded Rectangleは、その他のシェイブです」 が、マクロ実行ボタンでしょうね。＾＾；
じゃあ、ちょっとアプローチを変えてみて こんなのだとどうですか？
Sub test3()
Dim shp As Object
For Each shp In ActiveSheet.Shapes
If shp.OnAction <> "" Then
MsgBox shp.Name & "は、マクロ実行ボタンです。"
' shp.Delete
End If
Next
End Sub
(HANA)
マクロ実行しましたが、特になにも表示されなかったです
sakura
ん？ ボタン（角丸四角形の図形）にマクロは登録してもらってますか？
(HANA)
すみません(~_~;)
ボケでした。登録削除しておりました。すみません。
登録したら
「Rounded Rectangle １は、マクロ実行ボタンです」
と表示されました。
sakura
じゃあ、これを使います。 その部分を書き換えたコード↓。
'------
Sub 登録2()
Dim msg As String
Dim MyPath As String, MyBkN As String, MyShN As String
Dim BkIPath As String, LinkStr As String
Dim mxR As Long, MyN As Long
Dim dt As Variant, RngA As Variant
Dim BkI As Workbook
Dim shp As Object
RngA = Array("D2", "A6", "A2", "A8", "A4")
'番号,現場名,客先,内容,見積金額
'番号未入力確認
If Range(RngA(0)).Value <> "" Then
If MsgBox("番号が入力済みです。" & vbLf & _
"新しく番号を取得して登録しますか？", vbOKCancel) = vbCancel Then
Exit Sub
End If
End If
'必須項目入力確認
If Range(RngA(2)).Value = "" Then msg = msg & vbLf & vbTab & "客先"
If Range(RngA(1)).Value = "" Then msg = msg & vbLf & vbTab & "現場"
If Len(msg) > 0 Then
MsgBox "以下の項目が未入力です。" & msg & vbLf & _
"登録を中止します。"
Exit Sub
End If
'フォルダ存在確認
MyPath = ThisWorkbook.Path & "\" & Range(RngA(2)).Value
If Dir(MyPath, vbDirectory) = "" Then
MkDir MyPath
End If
'見積一覧表を開く
BkIPath = ThisWorkbook.Path & "\" & "見積一覧表.xls"
On Error Resume Next
Err.Clear
Open BkIPath For Append As #1
Close #1
If Err.Number > 0 Then
MsgBox "見積一覧表は開かれています。" & vbLf & _
"しばらくしてもう一度登録して下さい。"
Exit Sub
Else
Set BkI = Workbooks.Open(BkIPath)
End If
On Error GoTo 0
'最終行・番号取得
mxR = BkI.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
MyN = BkI.Application.Max(Sheets(1).Range("A1:A" & mxR)) + 1
'見積書保存
ThisWorkbook.Worksheets(1).Copy
For Each shp In ActiveSheet.Shapes
If shp.OnAction <> "" Then
shp.Delete
End If
Next
Range(RngA(0)).Value = MyN
MyBkN = Range(RngA(1)).Value & "_" & MyN & ".xls"
MyShN = Sheets(1).Name
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=MyPath & "\" & MyBkN, FileFormat:=xlExcel8
ActiveWindow.Close
Application.DisplayAlerts = True
'一覧表作成
ReDim dt(1 To 1, 1 To 7)
LinkStr = "='" & MyPath & "\[" & MyBkN & "]" & MyShN & "'!"
dt(1, 1) = "=HYPERLINK(G" & mxR + 1 & "," & MyN & ")"
dt(1, 2) = LinkStr & RngA(1)
dt(1, 3) = LinkStr & RngA(2)
dt(1, 4) = LinkStr & RngA(3)
dt(1, 5) = LinkStr & RngA(4)
dt(1, 6) = Date
dt(1, 7) = MyPath & "\" & MyBkN
BkI.Sheets(1).Range("A" & mxR + 1).Resize(, 7).Value = dt
Application.DisplayAlerts = False
BkI.Save
BkI.Close
Application.DisplayAlerts = True
Set BkI = Nothing
'転記終了
Range(Join(RngA, ",")).ClearContents
ThisWorkbook.Saved = True
MsgBox MyPath & " に" & vbLf & _
MyBkN & " で保存しました。" & vbLf & _
"番号は " & MyN & " です。"
End Sub
'------
(HANA)
出来ました！
助かりました、ありがとうございました。
お手数をおかけしました<m(__)m>
sakura
出来ましたか、良かったです。
今更なんですが ＞作成が終わったら、一つ一つリンク貼り付けしています。 って事は、リンク貼り付けで良かったんですよね？
それで、入力が無い所の対策はどうしているのですか？ 構わずリンクすると、「0」が表示されて目障りですよね。
「リンクが必要なセルに、未入力のセルは無い」 とかなんでしょうか？
(HANA)
ありがとうございます。
リンク貼り付けで大丈夫です。
あとで、他の人が見積書を確認するときに、
まず一覧表で、該当する見積書を探すので。
質問なのですが、
「一覧表」は、「テクスト（スペース区切り）」となっているのは、なぜですか？
もし「エクセルブック」で保存したら、どうなりますか？
・・・初歩的な質問ですみません。
あと、「０」表示されたところは、そのままにしてしまってます(~_~;)
でも、もし出来るなら表示されないようにしたいです。
可能でしょうか？
何度もすみませんが、よろしくお願いします
sakura
＞「一覧表」は、「テクスト（スペース区切り）」となっているのは、なぜですか？ あれ？なんで、txtだと思いましたか？ 一覧表ブックのパスは BkIPath = ThisWorkbook.Path & "\" & "見積一覧表.xls" の行で作っていますが、拡張子は「xls」＝エクセル ですよ？
エクセルだから、関数も入れられるし リンクも出来るのですが。。。
＞もし出来るなら表示されないようにしたいです。 あまり長い数式は入らないので、その制限に引っ掛からない様な所にブックがあるなら '一覧表作成 から始まる８行分を↓と入れ替えてみて下さい。
'一覧表作成
ReDim dt(1 To 1, 1 To 7)
LinkStr = "'" & MyPath & "\[" & MyBkN & "]" & MyShN & "'!"
dt(1, 1) = "=HYPERLINK(G" & mxR + 1 & "," & MyN & ")"
dt(1, 2) = "=IF(" & LinkStr & RngA(1) & "="""",""""," & LinkStr & RngA(1) & ")"
dt(1, 3) = "=IF(" & LinkStr & RngA(2) & "="""",""""," & LinkStr & RngA(2) & ")"
dt(1, 4) = "=IF(" & LinkStr & RngA(3) & "="""",""""," & LinkStr & RngA(3) & ")"
dt(1, 5) = "=IF(" & LinkStr & RngA(4) & "="""",""""," & LinkStr & RngA(4) & ")"
(HANA)
返信遅れまして申し訳ありません。
「見積一覧表」ですが、マクロ実行後は、「xls」で保存されています。
その後、ファイルと開こうとすると
「開こうとしているファイル”見積一覧表xls”は、実際にはその拡張子が示すファイル形式では
ありません。このファイルを開く前に、ファイルが破損していないこと、信頼できる発行先
からのファイルであることを確認して下さい。ファイルを開きますか？」
というメッセージが出ます。
そして、そのまま綴じると何もメッセージがでませんが、
「保存」を押すと
「見積一覧表xlsには、テキスト（タブ区切り）と互換性のない機能が含まれている可能性が
あります。この形式でブックを保存しますか？」
と、メッセージが出ます。
そして、「保存」を押すと、名前を付けて保存の画面が出て、
保存種類が「テキスト」になっていました。
sakura
ちなみに、もともとの拡張子は何でしたか？
(HANA)
もともとは、xlsでしたが、
97-2003ブックで保存してありました。
それを、2010に保存しなおしました。
教えていただいたように、「見積書」と「見積一覧表」は
\\LS-VL5BD\share\見積書\25年度 の中においています。
マクロを実行させると、\\LS-VL5BD\share\見積書\25年度の中に
新たに「見積一覧表」が作成されていて、
それを開くと、上記のようなメッセージが出てきます。
sakura
＞それを、2010に保存しなおしました。 って事は、拡張子が「xlsx」ですか？
コードの方はどこか変更しましたか？
(HANA)
そうです。拡張子は「xlsx」でした。
コードは、
RngA = Array("D2", "A6", "A2", "A8", "A4")
'番号,現場名,客先,内容,見積金額
↑これを
RngA = Array("L3", "C6", "A3", "B14", "E12")
'番号,現場名,客先,内容,見積金額
というように、当てはまるセルの場所に変更しました。
もしかして・・これがまずかったんですか？
sakura
いやいや、そこは変更して下さい。
開かないといけないブックが
BkIPath = ThisWorkbook.Path & "\" & "見積一覧表.xlsx"
なのに、コードの方が ~
BkIPath = ThisWorkbook.Path & "\" & "見積一覧表.xls"
のままなら、エラーにならないのかとおもいまして。。。 ~
たぶん、保存形式の問題だと思います。
とりあえず、↑の行を「xlsx」に直してもらうのと
見積書を保存する所で
MyBkN = Range(RngA(1)).Value & "_" & MyN & ".xls"
↓
MyBkN = Range(RngA(1)).Value & "_" & MyN & ".xlsx"
~
ActiveWorkbook.SaveAs Filename:=MyPath & "\" & MyBkN, FileFormat:=xlExcel8
↓
ActiveWorkbook.SaveAs Filename:=MyPath & "\" & MyBkN
にそれぞれ変更してもらうとどうですか？
(HANA)
出来ました！
ちゃんと、既存ファイルに入りました。
本当にありがとうございました。
それに、何度もスミマセンでした。
とても勉強になりました。
sakura
まぁ、先に聞いておくか 「excel2010」って書いてあるのに ちゃんと対応したものにしておかなかった方が悪いです。スミマセン。
上手くいって良かったです。
数式を入れる方はうまくいってますかね？
良く考えたら
＞'必須項目入力確認
で確認していないセルだけ =IF(〜〜 の式に直せばよかったですね。
たぶん、こんな感じで。
'一覧表作成
ReDim dt(1 To 1, 1 To 7)
LinkStr = "'" & MyPath & "\[" & MyBkN & "]" & MyShN & "'!"
dt(1, 1) = "=HYPERLINK(G" & mxR + 1 & "," & MyN & ")"
dt(1, 2) = "=" & LinkStr & RngA(1)
dt(1, 3) = "=" & LinkStr & RngA(2)
dt(1, 4) = "=IF(" & LinkStr & RngA(3) & "="""",""""," & LinkStr & RngA(3) & ")"
dt(1, 5) = "=IF(" & LinkStr & RngA(4) & "="""",""""," & LinkStr & RngA(4) & ")"
(HANA)
はい。
うまくいっています。
ありがとうございます。
ちなみに、上記のマクロに訂正しましたが、
前のマクロと、どう変わりますか？
sakura
見積一覧表の、B,C,D,E列を見てもらうと [１]． =セル番地 [２]. =IF(セル番地="","",セル番地) の二種類の数式で参照します。
一番最初のコードは、すべて [１]の数式。 二番目のコードは、すべて [２]の数式。 三番目のコードは、混合型です。
参照先のセルに入力が無かった時 [１]の数式ではセルに「0」が表示されてしまいますよね。 そこで、 入力が無かった時は「""」入力が有った時はそのセルの値を表示 と言う式を作ったのですが 現場名,客先 のセルは 必ず入力があるので 単純な[１]の式で参照すれば良いですよね。
もちろん、登録後にブックを開いて 対象セルの値を削除することがあるのなら やっぱりここも [２]の式が入っている方が良いのかもしれませんが。。。
(HANA)
おぉ〜
なるほど！
勉強になります。
ご説明頂きましてありがとうございました。
sakura
何度もすみません。
見積書の番号ですが、「１，２，３・・・」ではなく
「M25-1-1、M25-1-2、M25-1-3」と、いうようにしたいのですが、
どこを変更すればいいのでしょうか？
よろしくお願いします。
sakura
処理を簡単にする為に H列とI列を増やしてもらって良いですか？ A B C D E F G H I 1 番号 現場名 客先 内容 見積金額 登録日 保存場所 No M25-1 2 M25-1-1 大阪 あいう 製作 1 3 M25-1-2 東京 かきく 作業 2 4 M25-1-3 名古屋 さしす 取付 3 5 M25-1-4 福岡 たちつ 作業 4 6 M25-1-5 兵庫 なにぬ 製作 5
すると、コードは以下。
（これまでの変更も反映させたつもりですが。。。合わせて確認して下さい。）
'------
Sub 登録3()
Dim msg As String
Dim MyPath As String, MyBkN As String, MyShN As String
Dim MyN As String
Dim BkIPath As String, LinkStr As String
Dim mxR As Long, mxN As Long
Dim dt As Variant, RngA As Variant
Dim BkI As Workbook
Dim shp As Object
RngA = Array("L3", "C6", "A3", "B14", "E12")
'番号,現場名,客先,内容,見積金額
'番号未入力確認
If Range(RngA(0)).Value <> "" Then
If MsgBox("番号が入力済みです。" & vbLf & _
"新しく番号を取得して登録します。", vbOKCancel) = vbCancel Then
Exit Sub
End If
End If
'必須項目入力確認
If Range(RngA(2)).Value = "" Then msg = msg & vbLf & vbTab & "客先"
If Range(RngA(1)).Value = "" Then msg = msg & vbLf & vbTab & "現場"
If Len(msg) > 0 Then
MsgBox "以下の項目が未入力です。" & msg & vbLf & _
"登録を中止します。"
Exit Sub
End If
'フォルダ存在確認
MyPath = ThisWorkbook.Path & "\" & Range(RngA(2)).Value
If Dir(MyPath, vbDirectory) = "" Then
MkDir MyPath
End If
'見積一覧表を開く
BkIPath = ThisWorkbook.Path & "\" & "見積一覧表.xlsx"
On Error Resume Next
Err.Clear
Open BkIPath For Append As #1
Close #1
If Err.Number > 0 Then
MsgBox "見積一覧表は開かれています。" & vbLf & _
"しばらくしてもう一度登録して下さい。"
Exit Sub
Else
Set BkI = Workbooks.Open(BkIPath)
End If
On Error GoTo 0
'最終行・番号取得
With BkI.Sheets(1)
mxR = .Range("A" & Rows.Count).End(xlUp).Row
mxN = Application.Max(.Range("H1:H" & mxR)) + 1
MyN = .Range("I1").Value & "-" & Application.Text(mxN, "0000")
End With
'見積書保存
ThisWorkbook.Worksheets(1).Copy
For Each shp In ActiveSheet.Shapes
If shp.OnAction <> "" Then
shp.Delete
End If
Next
Range(RngA(0)).Value = MyN
MyBkN = Range(RngA(1)).Value & "_" & MyN & ".xlsx"
MyShN = Sheets(1).Name
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=MyPath & "\" & MyBkN
ActiveWindow.Close
Application.DisplayAlerts = True
'一覧表作成
ReDim dt(1 To 1, 1 To 8)
LinkStr = "'" & MyPath & "\[" & MyBkN & "]" & MyShN & "'!"
dt(1, 1) = "=HYPERLINK(G" & mxR + 1 & "," & MyN & ")"
dt(1, 2) = "=" & LinkStr & RngA(1)
dt(1, 3) = "=" & LinkStr & RngA(2)
dt(1, 4) = "=IF(" & LinkStr & RngA(3) & "="""",""""," & LinkStr & RngA(3) & ")"
dt(1, 5) = "=IF(" & LinkStr & RngA(4) & "="""",""""," & LinkStr & RngA(4) & ")"
dt(1, 6) = Date
dt(1, 7) = MyPath & "\" & MyBkN
dt(1, 8) = mxN
BkI.Sheets(1).Range("A" & mxR + 1).Resize(, 8).Value = dt
Application.DisplayAlerts = False
BkI.Save
BkI.Close
Application.DisplayAlerts = True
Set BkI = Nothing
'転記終了
Range(Join(RngA, ",")).ClearContents
ThisWorkbook.Saved = True
MsgBox MyPath & " に" & vbLf & _
MyBkN & " で保存しました。" & vbLf & _
"番号は " & MyN & " です。"
End Sub
'------
最後の番号は、直接「M25-1」の後ろにくっつけると M25-1-1 M25-1-2 M25-1-3 M25-1-11 M25-1-12 M25-1-13 と有った時に、並べ替えをすると M25-1-1 M25-1-11 M25-1-12 M25-1-13 M25-1-2 M25-1-3 になってしまうので M25-1-0001 の様にしています。
コード内では
MyN = .Range("I1").Value & "-" & Application.Text(mxN, "0000")
の部分なので、そのままつけたい場合は
MyN = .Range("I1").Value & "-" & mxN
「0」の数を変更したい場合は、ここで変更して下さい。
見積一覧が必ず番号で昇順になっている（あるいは、並べ替えても構わない）って事なら H列無しバージョンも作れますが。。。？
(HANA)
Sakura
風邪ひいて寝込んでまして、返信が遅くなってしまいました。
・・・すみません。
今、会社で実行してみました。
見積書の方は、うまく番号が「M25-1-1」と入ったのですが
一覧表の「番号」に、「−２」と入ってしまいます。
書式設定がまずいのでしょうか？
ちなみに、セルの書式設定は「標準」になっています。
sakura
風邪でしたか。大丈夫ですか？
＞見積書の方は、うまく番号が「M25-1-1」と入ったのですが
って事は、コードを
MyN = .Range("I1").Value & "-" & mxN
に変更しましたか？
＞一覧表の「番号」に、「−２」と入ってしまいます。 これは、A列の事ですよね？
A列に入っている数式と、H列に入っている数値を教えて下さい。
(HANA)
ありがとうございます。大丈夫です！
コードは、変更していなかったのですが、
ためしに変更してみましたが、結果は同じでした。
Ａ列に入っている式は
=HYPERLINK(G2,M25-1-1)
H列は式ではなく
１
と入っていました。
sakura
あ、わかりました。すみません。
ハイパーリンク関数を作るところ
dt(1, 1) = "=HYPERLINK(G" & mxR + 1 & "," & MyN & ")"
を以下の様に変更してみて下さい。
dt(1, 1) = "=HYPERLINK(G" & mxR + 1 & ",""" & MyN & """)"
そしたら、A列に入っている式が =HYPERLINK(G2,"M25-1-1") こうなると思いますので。
(HANA)
できました！！
A列の式も変わりました。
ありがとうございました。
本当に、何度もすみませんでした<m(__)m>
sakura
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.