- ベストアンサー
エクセルで重複データを増やす方法
- エクセル２００７で、表(1)の重複データを表(2)のように右の列に増やす方法についてのＶＢＡを教えてください。
- 重複データの行削除は理解できましたが、２列のキー列や右の列にデータを増やす方法がわかりません。
- レコードは１０００行以上、市idと社idは昇順に並んでおり、商品の種類は５０以上あります。
- nekonekomomo
- お礼率40% (2/5)
- Visual Basic
- 回答数3
- ありがとう数2
- みんなの回答 （3）
- 専門家の回答
質問者が選んだベストアンサー
＃２補足欄へのレスです。 エラーが出るとのこと。 掲示されている＃２のコードをコピーして再度繰り返し確認しましたが、 こちらでは問題なく処理できています。 記述の通りでテストしているのであれば、実際のシートのあり方と こちらが想定しているものとが違っているのかも知れませんね。 まず、 > 最後から７行目、 .Select だけでいいのでしょうか。 はい、合っています。 もしここがエラーになっている？、ということですと、 標準モジュールに貼るべきところをSheet1モジュールに貼っているとかですかね？ 特に断りがない場合は、マクロは標準モジュールに記述するものです。 私がちゃんと説明しておけば良かったですね。 ちょっと不親切でした。すみません。 対策として以下、 標準モジュールに貼って実行するか、または、Sheet1モジュールのまま 最後の23行分を以下の25行に差し替えてみてください。 Application.ScreenUpdating = False With Sheets("Sheet2") .Select ' ←要指定 出力シート名［ "Sheet2" ？］ .Cells.ClearContents rngS.Copy .Cells(1).PasteSpecial xlPasteColumnWidths .Cells.Resize(nPrtRow, tnCols).PasteSpecial xlPasteFormats If VarType(rngS(2, 2).Value) = vbString And rngS(2, 2).NumberFormat = "General" Then .Range("B2:C" & nPrtRow).NumberFormat = "@" End If If nPrtXSize > tnCols Then .Columns(tnCols).Copy .Columns(tnCols + 1).Resize(, nPrtXSize - tnCols).PasteSpecial xlPasteFormats End If With .Cells.Resize(nPrtRow, nPrtXSize) .Value = mtxP() .Select End With End With Application.CutCopyMode = False Application.ScreenUpdating = True Erase mtxP() Set rngS = Nothing End Sub 以上で解決が得られた場合は、以下読まなくて結構です。 > 試してみたところ、エラーになってしまいました。 どの行でエラーになっているか確認できますか？ エラーメッセージが表示されたら、[デバッグ]ボタンを押してみてください。 エラーの原因になっている行が黄色くハイライトされますので、 その行の記述とエラーメッセージの内容を教えてください。 ↑エラー相談時のルーティンです。 とりあえず、他に原因として思い付く点だけ、 １）元データシートでシートの保護を適用している場合 → 一旦シートの保護を解除して試してみる。 ２）元データシートの６列目、例示では空白列だけど、本当は違っている場合 ' ' 要指定 元データシート名↓［ "Sheet1" ？］ Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion mtxS() = rngS.Value tnRows = UBound(mtxS()) tnCols = UBound(mtxS(), 2) ↑この４行を以下の4行に差し替えて試してみる tnCols = 5 Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion.Resize(, 5) mtxS() = rngS.Value tnRows = UBound(mtxS()) ３）要指定と書かれた部分の指定を確認する。 ' ' 要指定 元データシート名↓［ "Sheet1" ？］ → 元データのシート名は "Sheet1" で合っていますか？ ReDim mtxP(1 To tnRows, 1 To 100) ' ←要指定 最大列数［ 100 ？］ → "商品"項目が右に並んで95品目を超える可能性があれば、 100 の数値を増やして対応してみてください。 Sheets("Sheet2").Select ' ←要指定 出力シート名［ "Sheet2" ？］ → 出力先のシート名は "Sheet2" で合っていますか？ ／／／／／ こちらも慎重さとか配慮が足らなかったかも知れません。 > 初心者の質問ですいません。 どうか、お気になさらず、、、。 更にお困りでしたら、遠慮なく訊いてください。 以上です。
その他の回答 (2)
- cj_mover
- ベストアンサー率76% (292/381)
＃１、ｃｊです。 出力側の書式全般についてケアしたものを書いてみました。 数字文字列の扱いは十分なものになっていると思います。 （↑これ、結構混乱する人多いので、、、。） その他の書式や列幅は元データシートを反映します。 "商品"の羅列、追加しました。 メインの処理は、配列変数を使って多少速くなります。 （書式処理で時間を喰うので調整の意味で替えました。） 諸々、難度はグっと上がって中級ぐらいですが、 レコード数が増えても殆どストレスないと思います。 各IDのソートは確実という前提です。 元データは何列あっても構いませんが、 連続した範囲の最右の列に"商品"項目列がひとつだけあることが条件になります。 元データの"商品"項目が複数列の場合も考えましたが、今回は対応しません。 各IDの数字文字列に関する注意点として、、 【文字列値"0001"】と【数値1、表示0001】のセルが混在している場合は、 別件として扱われます。 実際のシートで試してみないと、（お互いに）勝手がわからないと思いますが、 具体的な追加要件あれば、もう一度書きます。 Sub Re8087776j() Dim rngS As Range ' 元データ範囲 Dim mtxS() ' 元データ配列 Dim mtxP() ' 出力用データ配列 Dim tnRows As Long ' 元データ 行数 Dim tnCols As Long ' 元データ 列数 Dim iR As Long ' 元データ 行位置 Dim iC As Long ' 元データ 列位置 Dim nPrtRow As Long ' 出力先 行位置 Dim nPrtCol As Long ' 出力先 列位置 Dim nPrtXSize As Long ' 出力先 列総数 Dim sTmp As String ' 元データの連結キー Dim sKeyMrg As String ' 出力行の連結キー ' ' 要指定 元データシート名↓［ "Sheet1" ？］ Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion mtxS() = rngS.Value tnRows = UBound(mtxS()) tnCols = UBound(mtxS(), 2) ReDim mtxP(1 To tnRows, 1 To 100) ' ←要指定 最大列数［ 100 ？］ For iR = 1& To tnRows sTmp = mtxS(iR, 2) & vbLf & mtxS(iR, 3) If sTmp = sKeyMrg Then nPrtCol = nPrtCol + 1& mtxP(nPrtRow, nPrtCol) = mtxS(iR, tnCols) If nPrtCol > nPrtXSize Then nPrtXSize = nPrtCol Else nPrtRow = nPrtRow + 1& For iC = 1& To tnCols mtxP(nPrtRow, iC) = mtxS(iR, iC) Next iC sKeyMrg = sTmp nPrtCol = tnCols End If Next iR Erase mtxS() For iC = tnCols + 1& To nPrtXSize mtxP(1, iC) = mtxP(1, tnCols) Next iC Application.ScreenUpdating = False Sheets("Sheet2").Select ' ←要指定 出力シート名［ "Sheet2" ？］ Cells.ClearContents rngS.Copy Cells(1).PasteSpecial xlPasteColumnWidths Cells.Resize(nPrtRow, tnCols).PasteSpecial xlPasteFormats If VarType(rngS(2, 2).Value) = vbString And rngS(2, 2).NumberFormat = "General" Then Range("B2:C" & nPrtRow).NumberFormat = "@" End If If nPrtXSize > tnCols Then Columns(tnCols).Copy Columns(tnCols + 1).Resize(, nPrtXSize - tnCols).PasteSpecial xlPasteFormats End If With Cells.Resize(nPrtRow, nPrtXSize) .Value = mtxP() .Select End With Application.CutCopyMode = False Application.ScreenUpdating = True Erase mtxP() Set rngS = Nothing End Sub
補足
回答ありがとうございます。 試してみたところ、エラーになってしまいました。 最後から７行目、 .Select だけでいいのでしょうか。 初心者の質問ですいません。
- cj_mover
- ベストアンサー率76% (292/381)
こんにちは。 1000行ほど、ということなので、解り易さ優先のコードを書いてみました。 項目名"商品"の羅列は省略します。 技術的には For ... Next ループ 変数の扱い Rangeの扱い と、初級の内容で統一しています。 何か不足や疑問などありましたら、具体的に補足してみてください。 Sub Re8087776() Dim rngS As Range ' 元データ範囲 Dim tnRows As Long ' 元データ 行数 Dim tnCols As Long ' 元データ 列数 Dim iR As Long ' 元データ 行位置 Dim iC As Long ' 元データ 列位置 Dim nPrtRow As Long ' 出力先 行位置 Dim nPrtCol As Long ' 出力先 列位置 Dim sTmp As String ' 元データの連結キー Dim sKeyMrg As String ' 出力行の連結キー ' ' 要列数指定↓ tnCols = 5 ' ' 要シート指定↓ Set rngS = Sheets("Sheet1").Cells(2, 2).CurrentRegion.Resize(, tnCols) tnRows = rngS.Rows.Count Application.ScreenUpdating = False ' ' 要シート指定↓ Sheets("Sheet2").Select For iR = 1 To tnRows sTmp = rngS.Cells(iR, 2) & Format(rngS.Cells(iR, 3), "0000") If sTmp = sKeyMrg Then nPrtCol = nPrtCol + 1 Cells(nPrtRow, nPrtCol) = rngS.Cells(iR, tnCols) Else sKeyMrg = sTmp nPrtRow = nPrtRow + 1 nPrtCol = tnCols For iC = 1 To tnCols Cells(nPrtRow, iC) = rngS.Cells(iR, iC) Next iC End If Next iR Application.ScreenUpdating = True Set rngS = Nothing End Sub
お礼
できました！ Sheet1モジュールに貼っていました。的確なアドバイス、ありがとうございました。 処理速度も申し分ありません。 感謝、感謝です！