初心者です、お世話になります。
今まで商品の写真付き台帳を手入力していたのですが、誤入力が多く、
データベース的シート(以下、Masterシート)からデータを引っ張って台帳を作成したいです。
いろいろ試したのですが、Masterシート上の新規シートで台帳を完成させ、
その台帳シートのみマクロを外し、別ブックに保存といった流れがエラーも少ないと思います。
Masterシート、台帳ともなるべくマクロを作成しやすいように考えてレイアウトしましたが、
この限りではありません。
やりたいこと、
1:台帳作成開始シートにあらかじめ台帳のレイアウトを入れておく。
そこに、「台帳作成開始」ボタンと「完成&保存」ボタンを作る。
2:Masterシートの選択と原価の選択
Masterシートはシート名「春夏」、「秋冬」・・・と複数あります。
「台帳作成開始」ボタンでマクロ実行後、msgboxで「どのMasterシートを使用しますか?」と出て使用するMasterシートを選択。
次に、販売原価が店舗によって異なるためO列~A店、B店というように原価を記載しています。
msgboxで「どの店の台帳を作りますか?」と出て店舗(列)を選択。
※どちらもマクロ上で名前は入力し、今後増える場合にも対処したい。
2:選択されたシートと店舗(列)を使用し、台帳を作成。
msgboxで店舗(列)まで選ばれた時点で台帳作成シートをコピーし、新規シートに貼り付け。(できれば「台帳作成開始」ボタン削除)
「品名」右の空欄をアアクティブでプルダウンメニューに品名が表示され、選択すると写真も含め、関連するデータが貼り付けられる。
空欄にするとすべて消える。
※参考になるか分かりませんが、以前作成いただいたマクロを記載します。こちらは別ブックからMasterシートを取り込むマクロを実行した後、台帳に転記するマクロです。
3:選択した店舗(列)の店名をM1に転記
4:台帳が完成したら、「完成&保存」ボタンを押す。
保存先を指定し、保存するとマクロのない作成した台帳シートのみが保存される。
xlsx形式の保存で事足りるならそれでも構いません。
以上の流れです。
つたない説明ですが、よろしくお願いします。
VBA
1Private Sub Worksheet_Change(ByVal Target As Range) 2Dim rr As Long, cc As Integer 3Dim hno As String 4Dim sh As Worksheet 5Dim rng As Range 6Dim tmp As Variant 7Dim shp As Shape 8Dim fname As String 9'Constステートメント=定数定義 10Const fpath As String = "\\○○\○○\商品Master\" 11rr = Target.Row 12cc = Target.Column 13 14If rr > Cells(Rows.Count, "C").End(xlUp).Row Or rr Mod 7 <> 4 _ 15Or (cc <> 3 And cc <> 9 And cc <> 15) Then Exit Sub 16Application.ScreenUpdating = False 17Application.EnableEvents = False 18 19'削除 20If Target.Value = "" Then 21Range(Cells(rr, cc), Cells(rr + 6, cc)).ClearContents 22Range(Cells(rr, cc + 1), Cells(rr + 4, cc + 2)).ClearContents 23Cells(rr + 6, cc + 1).Value = "" 24'画像削除 25For Each shp In Shapes 26If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then 27If Not Intersect(shp.TopLeftCell, Target.Offset(0, -2)) Is Nothing Then 28shp.Delete 29End If 30End If 31Next shp 32'登録 33Else 34'Inster("ABCDE","D")は、数値の「4」を返します。 35hno = Left(Target.Value, InStr(Target.Value, " ") - 1) 36Set sh = Worksheets("Master") 37With sh 38Set rng = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row) 39tmp = Application.Match(hno, rng, 0) 40If IsError(tmp) Then 41MsgBox "画像はありません" 42Exit Sub 43Else 44 45Target.Value = hno 46Target.Offset(1, 0).Value = .Range("B" & tmp).Value 47Target.Offset(2, 0).Value = .Range("C" & tmp).Value 48Target.Offset(3, 0).Value = .Range("D" & tmp).Value 49Target.Offset(4, 0).Value = .Range("E" & tmp).Value 50Target.Offset(5, 0).Value = .Range("F" & tmp).Value 51Target.Offset(6, 0).Value = .Range("G" & tmp).Value 52Target.Offset(0, 1).Value = .Range("I" & tmp).Value 53Target.Offset(0, 2).Value = .Range("J" & tmp).Value 54Target.Offset(1, 1).Value = .Range("K" & tmp).Value 55Target.Offset(1, 2).Value = .Range("L" & tmp).Value 56Target.Offset(2, 1).Value = .Range("M" & tmp).Value 57Target.Offset(2, 2).Value = .Range("N" & tmp).Value 58Target.Offset(3, 1).Value = .Range("O" & tmp).Value 59Target.Offset(3, 2).Value = .Range("P" & tmp).Value 60Target.Offset(4, 1).Value = .Range("Q" & tmp).Value 61Target.Offset(4, 2).Value = .Range("R" & tmp).Value 62Target.Offset(6, 1).Value = .Range("S" & tmp).Value 63'画像 64fname = fpath & .Range("H" & tmp).Value 65With Target.Offset(0, -2) 66Set shp = ActiveSheet.Shapes.AddPicture(Filename:=fname, _ 67LinkToFile:=False, SaveWithDocument:=True, _ 68Left:=.Left, Top:=.Top, Width:=.MergeArea.Width, Height:=.MergeArea.Height) 69End With 70End If 71End With 72End If 73Application.EnableEvents = True 74Application.ScreenUpdating = True 75End Sub 76 77
回答1件
あなたの回答
tips
プレビュー