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

エクセルのマクロの質問です。商品情報が記載されたCSVファイルをエクセルで添付画像のサンプルのように商品番号、商品名を変更したいと考えています。
バーコードで管理するため、今までの商品番号にカラー、サイズの要素を入れるためです。
手作業で行うと1万近くになり、ミスが生じやすくなります。
そこでできればマクロで解決したいと思います。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

1214670644
●拡大する

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:CSV エクセル カラー コメント コード
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●0ポイント

一応ご希望の仕様に沿って作ってみました。

ただし、処理のしやすさから元のシートを変更するのではなく、先頭に結果のシートを出力しています。


元のシートを表示した状態で、実行してください。

Option Explicit

'------------------------------------------------------------------------
Sub RemakeItemCode()
'------------------------------------------------------------------------
 Dim lastRow As Long
 lastRow = Range("A" & Rows.Count).End(xlUp).Row

 Dim srcWS As Worksheet
 Set srcWS = ActiveSheet
 
'--- 結果を出力用に先頭に対象シートをコピー
 srcWS.Copy before:=Worksheets(1)
 
 Dim dstWS As Worksheet
 Set dstWS = Worksheets(1)
 
 dstWS.Range("A2:Z" & lastRow).Value = ""
 Dim cArray, sArray
 Dim srcRow As Long, dstRow As Long, ci As Long, si As Long
 Dim pCode As String, pName As String
 dstRow = 2
 For srcRow = 2 To lastRow
 cArray = Split(srcWS.Cells(srcRow, "G").Value, ":")
 sArray = Split(srcWS.Cells(srcRow, "H").Value, ":")
 For ci = LBound(cArray) To UBound(cArray)
 For si = LBound(sArray) To UBound(sArray)
 srcWS.Rows(srcRow).Copy Destination:=dstWS.Rows(dstRow)
 If makeItemInfo(pName, pCode, cArray(ci), sArray(si)) = False Then
  '--- オプション情報が不足していた場合、列を赤で表示
 dstWS.Range("A" & dstRow).Resize(1, 10).Interior.ColorIndex = 3
 End If
 dstWS.Cells(dstRow, "B").Value = srcWS.Cells(srcRow, "B").Value & pName
 dstWS.Cells(dstRow, "C").Value = srcWS.Cells(srcRow, "C").Value & pCode
 dstRow = dstRow + 1
 Next
 Next
 Next
End Sub

'------------------------------------------------------------------------
' 商品名と商品コードの情報を作成
'------------------------------------------------------------------------
Function makeItemInfo(ByRef pName, ByRef pCode, cOpt, sOpt) As Boolean
'------------------------------------------------------------------------
 Dim cArray, sArray
 cArray = Split(cOpt, "=")
 sArray = Split(sOpt, "=")
 If UBound(cArray) >= 2 And UBound(sArray) >= 2 Then
'--- ワンサイズの文字があるか判断
 If InStr(sOpt, "ワンサイズ") = 0 Then
 pName = "/" & cArray(1) & "/" & sArray(1)
 pCode = cArray(0) & sArray(0)
 Else
 pName = "/" & cArray(1)
 pCode = cArray(0) & sArray(0)
 End If
 makeDstInfo = True
 Else
 pName = ""
 pCode = ""
 makeDstInfo = False
 End If
End Function

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

修正しました。


先のもバグがありました。

大変申し訳ありません。

関数名の中で返す値が関数名と異なるため、すべて偽となっていました。


今回の仕様の変更上、オプションチェックは外しましたが、オプションの書式の確認が必要でしたら

コメントください。

対策を考えます。

Option Explicit

'------------------------------------------------------------------------
Sub RemakeItemCode()
'------------------------------------------------------------------------
 Dim lastRow As Long
 lastRow = Range("A" & Rows.Count).End(xlUp).Row

 Dim srcWS As Worksheet
 Set srcWS = ActiveSheet
 
'--- 結果を出力用に先頭に対象シートをコピー
 srcWS.Copy before:=Worksheets(1)
 
 Dim dstWS As Worksheet
 Set dstWS = Worksheets(1)
 
 dstWS.Range("A2:Z" & lastRow).Value = ""
 Dim cArray, sArray
 Dim srcRow As Long, dstRow As Long, ci As Long, si As Long
 Dim pCode As String, pName As String
 dstRow = 2
 For srcRow = 2 To lastRow
 cArray = Split(srcWS.Cells(srcRow, "G").Value & ":", ":")
 sArray = Split(srcWS.Cells(srcRow, "H").Value & ":", ":")
 For ci = LBound(cArray) To UBound(cArray)
 For si = LBound(sArray) To UBound(sArray)
 If makeItemInfo(pName, pCode, cArray(ci), sArray(si)) = True Then
 srcWS.Rows(srcRow).Copy Destination:=dstWS.Rows(dstRow)
 dstWS.Cells(dstRow, "B").Value = srcWS.Cells(srcRow, "B").Value & pName
 dstWS.Cells(dstRow, "C").Value = srcWS.Cells(srcRow, "C").Value & pCode
 dstRow = dstRow + 1
 End If
 Next
 Next
 Next
End Sub

'------------------------------------------------------------------------
' 商品名と商品コードの情報を作成
'------------------------------------------------------------------------
Function makeItemInfo(ByRef pName, ByRef pCode, cOpt, sOpt) As Boolean
'------------------------------------------------------------------------
 Dim cArray, sArray
 cArray = Split(cOpt, "=")
 sArray = Split(sOpt, "=")
 If UBound(cArray) >= 1 And UBound(sArray) >= 1 Then
'--- ワンサイズの文字があるか判断
 If InStr(sOpt, "ワンサイズ") = 0 Then
 pName = "/" & cArray(1) & "/" & sArray(1)
 pCode = cArray(0) & sArray(0)
 Else
 pName = "/" & cArray(1)
 pCode = cArray(0) & sArray(0)
 End If
 makeItemInfo = True
 Else
 makeItemInfo = False
 End If
End Function
関連質問


●質問をもっと探す●



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