人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルVBA、文字列を読み取ってシートに貼り付けるマクロについて

商品名を読み取って、商品を保管場所から、ピックアップするためのマクロをつくりたいです。

・シートは2つあります。(★と場所)

・★はA列に商品名があり、商品名の最後付近に、
半角英数字が1か2文字分あります

その半角英数字が場所をしめしていて、


マクロを実行すると

「場所」シートの同じ個所に★シートA列の商品名を貼り付けたいのです。
その時に、K列にある、商品番号も同じようにくっついて「場所」シートにはりつけます。

詳細は画像をご確認ください。


注意点は追記いたします。


どうかよろしくお願いいたします。


1370344329
●拡大する


●質問者: naranara19
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

質問者から

注意点として、
・場所の最後の半角英数字1文字か2文字の最後にまれにスラッシュがつくことがありますが、これは無視します。

・半角、全角、大文字、小文字はすべて区別します。

・書式ごとコピーしていただきますよう、お願いいたします。

・該当場所がないときには、失敗したセルの背景が真っ黒になり、次の行に移ります。

・場所シートの該当場所はA,D,G列、行数は60まであります。(途中空白の場合あり)
これを列=3、行=60を初期値として、指定を変えられるようにしてくださると助かります。指定内を実行します。


1 ● sinrabanshyo
●100ポイント

vlookup関数使うと行けそうな気がしますが。。。。
部分一致とか条件いるんでしょうか。


naranara19さんのコメント
こんにちは。業務で使用しておりまして、一発処理のVBAにてお願いしたいのです。よろしくお願いいたします。

2 ● Mook
●100ポイント ベストアンサー

こんな感じのことでしょうか。

Option Explicit

Sub 文字列を読み取ってシートに貼り付ける()
 Dim srcWS As Worksheet
 Set srcWS = Worksheets("★")
 
 Dim dstWS As Worksheet
 Set dstWS = Worksheets("場所")

 Dim objDic As New Scripting.Dictionary '// ツール ⇒ 参照設定 ⇒ Microsoft.Scriting.RunTime にチェック

 Dim dc As Long
 Dim r As Range
 For dc = 1 To 8 Step 3
 For Each r In dstWS.Cells(1, dc).Resize(60, 1)
 If r.Value <> "" Then objDic(CStr(r.Value)) = r.Column
 Next
 Next
 
 Dim ky1 As String
 Dim ky2 As String
 Dim dr As Range
 For Each r In srcWS.Range("A2", srcWS.Cells(Rows.Count, "A").End(xlUp))
 If r.Value <> "" Then
 If Right(r.Value, 1) = "/" Then
 ky2 = Replace(Trim(Right(" " & r.Value, 3)), "/", "")
 Else
 ky2 = Trim(Right(" " & r.Value, 2))
 End If
 ky1 = Right(ky2, 1)
 
 If objDic.Exists(ky2) = True Then
 Set dr = dstWS.Columns(objDic(ky2)).Find(ky2, lookat:=xlWhole)
 ElseIf objDic.Exists(ky1) = True Then
 Set dr = dstWS.Columns(objDic(ky1)).Find(ky1, lookat:=xlWhole)
 Else
 Set dr = Nothing
 r.Interior.ColorIndex = 1
 End If
 If Not dr Is Nothing Then
 If dr.Offset(0, 1).Value = "" Then
 r.Copy Destination:=dr.Offset(0, 1)
 r.Offset(0, 10).Copy Destination:=dr.Offset(0, 2)
 Else
 Set dr = dr.Offset(1, 0)
 Do While dr.Value = "" And dr.Offset(0, 1).Value <> ""
 Set dr = dr.Offset(1, 0)
 Loop
 dr.Resize(1, 3).Insert xlDown
 r.Copy Destination:=dr.Offset(-1, 1).Resize(1, 2)
 r.Offset(0, 10).Copy Destination:=dr.Offset(-1, 2)
 End If
 End If
 End If
 Next
End Sub

Mookさんのコメント
Loop の条件が誤っていたので修正しました。

naranara19さんのコメント
Mookさん、すみません。お手数をおかけして。 やってみたのですが、 コンパイルエラー: ユーザ定義型は定義されていません。 と、 Dim objDic As New Scripting.Dictionary '// ツール ⇒ 参照設定 ⇒ Microsoft.Scriting.RunTime にチェック の箇所で止まってしまいます。ご回答ありがとうございます

Mookさんのコメント
コメントの通り、VBE で参照設定してください。

naranara19さんのコメント
Mookさん、すみませんでした。いろいろといじってみましたが、完璧に動きました。おひさしぶりです。お忙しい中、素晴らしいご回答本当にありがとうございました。「はてな」で相変わらずご活躍しているようで、とてもうれしくなりました。本当にありがとうございます!

naranara19さんのコメント
Mookさん、すみません。 「これを列=3、行=60を初期値として」 という部分ですが、読み取る列をJ列まで1つ増やしたときは、 どこを変えていけばよいでしょうか?お手数ですが、 教えていただけないでしょうか?行の60のほうはこちらでわかります。 お手数をおかけしますがよろしくお願いいたします。

naranara19さんのコメント
Mookさん、すみません。追加調査しておりましたら、場所シートに単に数字「3」とか「13」とか場所の時にうまく反応していないことがわかりました。 りんご青森県産3というタイトルでしたら、場所に3があっても黒塗りされたエラーが出てしまうのです。ぜひこちらもご対処いただけますでしょうか。お手数をおかけいたします。 (急ぎではありませんので、数日内にご回答いただけたら幸いです)

Mookさんのコメント
辞書のキーを文字列にしましたが、これでどうでしょうか。

naranara19さんのコメント
ありがとうございます。 ★のA列にある、りんご青森県産13とあったら、13の場所にはいるのではなく、場所3のところに入ってしまいます。場所は英数字半角の組み合わせでして、1文字か2文字なのです。

Mookさんのコメント
キーは2文字から検索しているので長い方にマッチするはずですが、 13はどちらも半角で、データの末尾にスペースが入ったりしていないでしょうか。 あとは実際にトレースをしながら変数の中身を確認するしかないですね...。

naranara19さんのコメント
ありがとうございます! またこの質問の疑問がありましたら、再度質問を立ててリクエストいたしますね。 仕様が半角の1文字や2文字と安定しないのでご迷惑をおかけしました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ