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

【再度】【エクセルVBA】文字列を読み取ってペーストしたい


シートが2つあります「★」「場所」

★シートのA列にタイトル、K列に管理番号が下に並びます」。特定の条件(※)を満たすものをコピーし、場所シートにペーストします。


※特定の条件
★シートK列内の管理番号は151214000AJKなど、先頭の9ケタが数字です。それが160108以降のものを抽出し、その数字を降順にしたあとに残りの文字もくっつけなおして場所シートにはりつけます。半角ですが、英大文字と小文字は区別します。タイトル最後に「/」があるものもまれにあり、除いて考えます。その2文字は同じ値が場所シートのA列のA、C,E,G,I列の、ともに199行目まで入っていることがあり、これと一致する場合だけは除き、一致しないタイトルのみ(160108以降)を抽出し、

場所シートのB200から下に、D200からはB列の商品番号に対応するタイトルをペーストします。

注意点
・★シートのK列管理番号が空白、もしくは7桁が数字となっていないものは無視します。
・タイトルの後の2文字は1文字の時有(mやe、★等)記号使用もあり(-等)
最後のスラッシュを除き、最大半角2文字分までです。

1452477297
●拡大する

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

▽最新の回答へ

1 ● a-kuma3
●300ポイント ベストアンサー

以下のコードを標準モジュールに貼り付けて、copy_item_data サブルーチンを実行してください。
アクティブなシートを対象にして、該当するデータを "場所" シートに複写します。

Const MAX_ROW = 10000
Const BASE_ITEM_NUMBER = 160108000


Function is_blank_cell(c)
 is_blank_cell = IsEmpty(c) Or c.Value = ""
End Function


Function is_need_copy(item_number, c_name, re_mark, mark_map)
 is_need_copy = True
 If item_number < BASE_ITEM_NUMBER Then
 is_need_copy = False
 Else
 Set remat = re_mark.Execute(c_name.Value)
 If remat.Count > 0 Then
 mark = remat(0).Submatches(0)
 mark1 = Right(mark, 1)
 If mark_map.Exists(mark) Then
 is_need_copy = False
 ElseIf mark_map.Exists(mark1) Then
 is_need_copy = False
 End If
 End If
 End If
End Function


Sub copy_item_data()
 Set dest_sheet = Sheets("場所")

 Set re_mark = CreateObject("VBScript.RegExp")
 re_mark.Pattern = "(..)/?$"

 Set mark_map = CreateObject("Scripting.Dictionary")

  ' A, C, E, G, I 列の文字を読み取る
 For r = 2 To 199
 For c = 1 To 9 Step 2  ' A, C, E, G, I
 v = CStr(dest_sheet.Cells(r, c).Value)  ' ★ここを変えました
 If v <> "" And Not mark_map.Exists(v) Then
 mark_map.Add v, v
 End If
 Next
 DoEvents
 Next

 dest_r = 200
 r = 2
 blank_count = 0
 Do Until blank_count = 20  ' 空白行が20行続いたら打ち切り
 Set c_num = Cells(r, 11)  ' K 列
 Set c_name = Cells(r, 1)  ' A 列
 If is_blank_cell(c_num) Then
 blank_count = blank_count + 1
 Else
 blank_count = 0
 item_number = Val(Left(c_num.Value, 9))
 If is_need_copy(item_number, c_name, re_mark, mark_map) Then
 c_num.Copy dest_sheet.Cells(dest_r, 4)  ' 商品番号
 c_name.Copy dest_sheet.Cells(dest_r, 2)  ' 商品名
 dest_sheet.Cells(dest_r, 6).Value = item_number  ' 商品番号(上9ケタ)
 dest_r = dest_r + 1
 End If
 End If
 DoEvents
 r = r + 1
 If r > MAX_ROW Then  ' 念のため
 Exit Do
 End If
 Loop

  ' 商品番号の上9ケタの降順で並べ替え
 dest_sheet.Range(dest_sheet.Cells(200, 1), dest_sheet.Cells(dest_r, 6)).Sort Key1:=dest_sheet.Range("f200"), Order1:=xlDescending

 Set re_mark = Nothing
 Set mark_map = Nothing
End Sub

並べ替えに使うために、「場所」シートの F列に商品番号の頭9ケタの数字を入れてます。
入れたままにしてますが、邪魔なようでしたら並べ替えの後に消す処理を入れてください。

  ' 商品番号の上9ケタの降順で並べ替え
 dest_sheet.Range(dest_sheet.Cells(200, 1), dest_sheet.Cells(dest_r, 6)).Sort Key1:=dest_sheet.Range("f200"), Order1:=xlDescending

  ' 商品番号の上9ケタを消す
 dest_sheet.Range(dest_sheet.Cells(200, 6), dest_sheet.Cells(dest_r, 6)).ClearContents



追記です。

りんご6/
とか
みかん/14を

B200以上のところに書き込んでしまいます。

「場所」シートの 199行目までに書かれている商品名の末尾が数値になっているときの考慮が抜けていました。
先に書いた回答のコードを修正しましたので、確認してみてください。


naranara19さんのコメント
ありがとうございます!! 14とか6の保管場所があるものを拾ってしまうみたいです。 りんご6/ とか みかん/14を B200以上のところに書き込んでしまいます。 その対応をお願いできますでしょうか? お手数をおかけいたします。

naranara19さんのコメント
完璧でした。長々とお付き合いいただき、誠にありがとうございました!心より感謝しております。
関連質問

●質問をもっと探す●



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