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


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

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

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

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


マクロを実行すると

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

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


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


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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/06/04 20:12:09
  • 終了:2013/06/11 20:15:03
id:naranara19

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

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

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

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

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

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912013/06/08 22:20:14

ポイント100pt

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

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
他8件のコメントを見る
id:Mook

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

2013/06/11 13:05:03
id:naranara19

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

2013/06/11 21:01:52

その他の回答(1件)

id:sinrabanshyo No.1

sinrabanshyo回答回数139ベストアンサー獲得回数172013/06/05 15:49:40

ポイント100pt

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

id:naranara19

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

2013/06/05 17:34:57
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912013/06/08 22:20:14ここでベストアンサー

ポイント100pt

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

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
他8件のコメントを見る
id:Mook

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

2013/06/11 13:05:03
id:naranara19

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

2013/06/11 21:01:52
  • id:naranara19
    ★シートの商品名ですが、見出しからずっと下に続き、空白時に止まるという形でお願いいたします。60行というのは「場所」シートのほうで、これは調節できるようにお願いいたします。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません