エクセルのマクロについて教えて下さい！

Question

これまで手入力で色々集計表を作っていましたが、新しく管理システムが導入され、データベースからデータを抽出できる様になったのですが・・・。データベースからの抽出だけでは楽に集計表を作製することが出来なく、手間が増えてしまいました。
せっかく楽になると思ったのに・・と添付のようなまとめがエクセルのマクロで出来ないか相談させて頂きました！どなたかこのプログラム作製できる方居られましたら御教授御願い致します！！

WindFaller · Accepted Answer

>1901-002『か』のデータが1812-003『う』のデータに変わっていて、
>1812-003『う』が２個に増えているようです。

ごめんなさい、それだけを抽出して指摘されても、もう直しようがありません。
厳密に言えば、私のプロクラムの問題だと言われれば否定しようもありませんが、論理的なミスだとは思えないのです。今の私としては、画像ではなく生のデータをいただかないと、もう限界ではないかと思っています。

私自身、仕事で人が入力したデータをデータ分析に使ったことはありますが、出力されたものを、そのまま使うこということはできませんでした。一旦、ソートして、それでそれぞれのデータの同じ製品番号の一番上にあるものを元にして、コピーするという作業をします。

例えば、
1:"1901-002"
2:"190１-002"
3:" 1901 -002"

これらは、一緒に見えますが、全部違う製品番号になってしまいます。そこで、修正を加えないと使えないのです。

これらの問題について、ある程度は想定はできますが、「製品番号」のパターンが、純粋に半角の数字と半角ダッシュ(-)で出来ていればよいのですが、スペースが入ったり、ダッシュの違いや、半角空白が混じっていたり、少しでも違えば別だと判断してしまいます。

DataList.Contains(.Cells(i, 1).Value)

今は、このように、そのまま加工せずに代入しています。

それは、実際にどういうデータかにもよりますが、こちらで想定しても、こちらの想定外なことについては、忖度してああではないか、こうではないかと、修正を何度も繰り返してしまうこともありますが、掲示板の回答として、質問者から、余計なことをするなと文句をつけられたり、分かりにくい書き方だから、ボツだとされることが多いのです。

今は、バイナリー比較している関係で、ピッタリ同じでないと正しい結果が得られません。これに対して、テキスト比較という方法はありますが、まだ、試してはいませんが、それは、使えない可能性があるので、DataList.Contains に入れる前に、一定の法則で加工して代入してあげないといけないような気もします。

なんとか、原因に、データ上のブレがないのか、その部分をよく調べていただけたら解決する可能性がありますが、そうでないと、これ以上は、こちらでは無理だと思っています。

WindFaller · Answer

改良点・変更点：
・第Ⅱ表の区切りの入力はいりません。マクロで2番めの「製造番号」という文字を探すことにしました。
実質的に3行目からデータが始まるのはキメウチにしています。手作業で変えられますが、3となる部分を変更すれば可能です。

・.Net Framework Ver.2 以上だからおそらくどのPCでも問題はでないと思います。Excel は、理屈では、2003も動くはずです。ただ、SortedList オブジェクトの仕組みは、私は完全に理解していませんが、製造番号でソートが掛るような仕組みになっているはずです。

コピーコマンドを使っていますので、色塗りは、そのまま反映させれます。
まだまだ、データによっとは変な出力が出るかもしれません。

※使用上の注意：元シートのA列に、不要なデータを置かないようにしてください。サイズを、A列の行の末尾までと解釈しているからです。

'//標準モジュール
Sub ConsoliPro()
　Dim sh1 As Worksheet
　Dim sh2 As Worksheet
　Dim Col2 As Long
　Dim ColEnd As Long
　Dim c As Variant
　Dim n1 As Variant
　Dim n2 As Long
　Dim DataList As Object
　Set DataList = CreateObject("System.Collections.SortedList")
'-------------------------------------
  '//ユーザー設定
　Set sh1 = Worksheets("Sheet1")
　Set sh2 = Worksheets("Sheet2")
'-----------------------------------
　If sh2.UsedRange.Count > 2 Then
　   If MsgBox(sh2.Name & "のデータを消して良いですか？", vbOKCancel) = vbCancel Then Exit Sub
　　sh2.UsedRange.Clear
　End If
　DataList.Clear
　With sh1
　　Set c = .UsedRange.Find("製造番号", After:=.Range("A2"))
　　Col2 = c.Column '表Ⅱの列決定
　　ColEnd = .Cells(3, Columns.Count).End(xlToLeft).Column
　　w = ColEnd - Col2 + 1
　　'タイトル行のコピー
　　.Range("A2").Resize(, Col2 - 1).Copy sh2.Range("A2")
　　.Cells(2, Col2 + 1).Resize(, w).Copy sh2.Cells(2, Col2)
　　Set Rng = .Range("A3", .Cells(Rows.Count, 1).End(xlUp).Offset(, 1))
　　'表Ⅰ
　　With Rng
　　　For i = 1 To .Rows.Count
　　　　If DataList.Contains(.Cells(i, 1).Value) = False Then
　　　　　DataList.Add .Cells(i, 1).Value, .Cells(i, 2).Row
　　　　Else
　　　　　DataList.Add .Cells(i, 1).Value & "+" & .Cells(i, 2).Row, ""
　　　　End If
　　　Next i
　　End With
　　'表Ⅱ
 
　　Set Rng = .Range(.Cells(3, Col2), .Cells(Rows.Count, Col2).End(xlUp).Offset(, 1))
　　With Rng
　　　For j = 1 To .Rows.Count
　　　　If DataList.ContainsKey(.Cells(j, 1).Value) Then
　　　　  DataList.Add .Cells(j, 1).Value & "^" & Format(.Cells(j, 2).Row, "00"), ""
　　　　Else
　　　　  DataList.Add .Cells(j, 1).Value, "-" & Format(.Cells(j, 2).Row, "00")
　　　　End If
　　　Next j
　　 End With
　  End With
　  With sh2
　　　.Cells(1, 1).Value = "表Ⅲ＝表I + 表Ⅱ"
　　　For i = 0 To DataList.Count - 1
　　　 dt = DataList.GetKey(i)
　　　 idx = DataList.GetByIndex(i)
　　　 k = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row '
　　　 If Val(idx) > 0 Then
　　　   sh1.Cells(idx, 1).Resize(, Col2 - 1).Copy .Cells(k, 1)
　　　 ElseIf Val(idx) < 0 Then
　　　   .Cells(k, 1).Value = dt
　　　　sh1.Cells(-idx, Col2 + 1).Resize(, w).Copy .Cells(k, Col2)
　　　 ElseIf InStr(dt, "^") > 0 Then
　　　 n1 = Split(dt, "^")(0)
　　　 n2 = Split(dt, "^")(1)

.Cells(k, 1).Value = n1
　　　　sh1.Cells(n2, Col2 + 1).Resize(, w).Copy .Cells(k, Col2)
　　　 ElseIf InStr(dt, "+") > 0 Then
　　　   sh1.Cells(n2, 1).Resize(, w).Copy .Cells(k, 1)
　　　 End If
　　　Next
　　　.Range(.Cells(2, 1), .Cells(k, ColEnd - 1)).Borders.LineStyle = xlContinuous
　   End With
　End Sub

WindFaller · Answer

遅くなって申し訳ないです。Weekday は、空いていればできるのですが、なかなか思うようになりません。Weekend にまとめてやるしないようです。

コードを作ってみて、こちらの思っていたものとまったく違っていましたので、全面的にコードを書き変えました。

>当然ながら、No.3さんのコードは織り込み済みで、こちらでは納得できなかったというよりも、違う法則からアプローチで、

と書きましたが、同類の方法で、SortedList(.Net Framework) というオブジェクトを使いました。どうやら、ソートが入っているように見受けたからです。

ただ、まだ、コードを貼り付けるよりも、出来上がりからみていただいて検討していただきたいです。
赤丸の部分が、どうしても、ひっくり返りません。表Ⅰ～表Ⅱとデータを拾っているので、出た順に収納しているようです。

WindFaller · Answer

>同じ製造番号で品名Bが、例えば費用aと費用ｃに別々に費用があった場合（作業した日が違うので行が別）

この表のマクロの構造は、本当に単純な作りでできています。別に日付を探すとかいう高級なことはしていません。比較するものに、特定の列に日付が加わっていれば、それを一行ないし二行含めますが、それを聞いてなければ、それを予め想定することは不可能なのです。

一体、日付はどこの列にあるのですか？

今のマクロで試してみましたが、ダブリが消えるという問題を認識できませんでした。それは、現行の表だけでは、「日付」がないからです。

>いつから②何を③誰が④何を使って⑤どれだけの時間を掛けて⑥何個⑦いつ作り終わったのか、

>作るのに⑧何を⑨どこから⑩いつ⑪いくらで買ったのか

もしかしたら、今まで、ここで見てきたのは、ひとつのブロックなのですか？
ブロックごとの処理を、別々に扱わないで混ぜて処理しないと、そのような現象は現れないように思うのです。

そうすると、まったく扱いが変わってきてしまいます。今度は、どのようにしてブロックと認識するかということになります。なにやら雲行きが怪しくなってきたような気がします。具体例があれば、かなり違ってきますが、そこには限界があるのかもしれません。

ひとつのブロックとして扱うには、日付を元にしたシリアル番号のようなものを作ってあげないと表計算では処理できないと思います。

WindFaller · Answer

>実際に使う集計表で確認した結果ですが、製造番号が違うと別物扱いになっていますが、同じ製造番号で品名Bが、例えば費用aと費用ｃに別々に費用があった場合（作業した日が違うので行が別）、項目名は違いますが、金額が同じだと表Ⅲではダブりと認識されてしまい1行になり、元あったもう１行のデータが消えてしまいます。

この件は、気づいていました。聞こうかどうしようか、迷ったのですが、そのまま言葉だけで納期を伸ばすのは問題かと思い、敢行してしまったという具合です。（これがMicrosoft 方式かな（^^;　半製品でも、製品を見せることなのです。)

実は、どうすべきかわからなかったからです。
●本来なら、合算（数式が合計)すべきかとも思いました。

>表Ⅰ側だけがこういった事象になっているようですが、これを別ものとして扱う事は出来ますでしょうか？

たぶん、合計するよりは簡単だと思いますが、どうなるのかは分かっていません。

一応、こんなサンプル・あんなサンプルというものがあると、考える材料になるのですが、パターンは、これだけでは済まない気がしてならないのです。

ただ、すでに、このマクロの設定を入れて表がごちゃごちゃにならずに、作られる事自体が、こちらの想定よりも、ご質問者さんは、期待以上なのです。ここで、ポシャってしまうかと思いました。

この表の統合には、法則がいくつかあるはずで、残念ながら、全部を含めていないようなのです。それが主な原因で、つまるところ、私が、表の意味が本当は理解していないからにほかならないのです。

当然ながら、No.3さんのコードは織り込み済みで、こちらでは納得できなかったというよりも、違う法則からアプローチで、No.4,No.5ができているわけです。方向性は間違いなかったようです。しかし、同時に最終段階には至っていないようです。

もう少しご辛抱を願い、お付き合いください。

WindFaller · Answer

No.4 の回答者です。遅くなりました。別のPCでやるとなぜかエラーになるので、行ったり来たりしながら作りました。 >物を作るのにどれだけの手間と材料などが必要か？なんとなくわかるのですが、仕入予算を出すとかはあっても、まったく未知の分野です。このような表を作った経験がありません。私は、とても勉強になります。本来は、お仕事場で、実際はこう使うのだよ、とお話をお聞きしたいくらいです。さて、ユーザー設定で少し説明すると、 stRow は、元のシートのタイトル行の位置 st2Col は、元シートの表Ⅱの開始列です。10項目あったら、12辺りになるはずです。 stRow2 は、シート2のタイトル行を予定している場所です。後、何か付け加えるオプション（例：印刷設定)が必要な場合は、早めにお知らせください。単純な内容ですが、ごちゃごちゃしていますので、わからなくなりそうです。 '// Sub Consolidate3r() 　Dim Sh1 As Worksheet 　Dim Sh2 As Worksheet 　Dim Rng1 As Range, r2 As Range 'ソートの範囲　Dim st2Col As Long '第2表の始まり列　Dim stRow As Long, stRow2 As Long 'スタート行　Dim lastCol As Long, lastRow As Long, endRow As Long, lastRow2 As Long 　Dim midRow As Long, maxRow As Long, lastCol2 As Long 　Dim i As Long 　'--------ユーザー設定-- 　stRow = 2 '元シートのタイトル行　st2Col = 7 '元シートの表Ⅱの開始列 -　G列=7 　stRow2 = 2 '転記先の開始行　maxRow = 500 '最大使用行(特に変更する必要はない) 　Set Sh1 = Worksheets("Sheet1") '元のシート　Set Sh2 = Worksheets("Sheet2") '転記するシート　'------------------ 　With Sh1 　　'元シートのチェック　　lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column '2行目がタイトル行　　If lastCol < 4 Then MsgBox "表の設定が違うようです。", vbExclamation: Exit Sub 　　midRow = .Cells(stRow, "A").End(xlDown).Row 　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row 　　If midRow <> lastRow Then 　　　MsgBox "現在の設定では、1シートに表やデータが複合になっているものは、実行できません。", vbExclamation: Exit Sub 　　End If 　　If Not .Cells(stRow, st2Col).Value Like "*製造*" Then 　　 '「製造という文字を項目から探しています。」　　　Application.Goto .Cells(stRow, st2Col) 　　　MsgBox "ユーザー設定の表Ⅱの開始位置(" & st2Col & ")が違うようです。", vbExclamation: Exit Sub 　　End If 　　Set r2 = Sh2.UsedRange 'データのある無しを調べる　　If Application.CountA(r2) > 1 Then 　　　If MsgBox(Sh2.Name & "のデータを消してよいですか？", vbOKCancel + vbDefaultButton2) = vbCancel Then Exit Sub 　　　'r2.Clear 'データ外のデータを置く時　　　 Sh2.Rows(stRow).Resize(maxRow).Clear '転記シートのデータを全部消す　　End If 　　'初期項目の転記　　lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column 　　.Range(.Cells(2, 1), .Cells(2, st2Col - 1)).Copy Sh2.Cells(stRow2, 1) 　　.Range(.Cells(2, st2Col + 2), .Cells(2, lastCol)).Copy Sh2.Cells(stRow2, st2Col) 　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row 'sh1's lastrow 　　.Range(.Cells(stRow + 1, "A"), .Cells(lastRow, st2Col - 1)).Copy Sh2.Cells(stRow2 + 1, 1) 　 ' midRow = .Cells(stRow, st2Col).End(xlDown).Row '二分した表の次の表　　lastRow2 = Sh2.Cells(Rows.Count, 1).End(xlUp).Row 'sh2's lastrow 　　.Range(.Cells(stRow + 1, st2Col), .Cells(midRow, st2Col + 1)).Copy Sh2.Cells(lastRow2 + 1, "A") 　　.Range(.Cells(stRow + 1, st2Col + 2), .Cells(midRow, lastCol)).Copy Sh2.Cells(lastRow2 + 1, st2Col) 　End With 　'転記シートの操作の始まり　With Sh2 　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　lastCol = .Cells(stRow2, Columns.Count).End(xlToLeft).Column 　　Set Rng1 = .Range(.Cells(stRow2, 1), .Cells(lastRow, lastCol)) 　　Application.ScreenUpdating = False 　　'一旦ソートを掛ける　　With Rng1 'セルの中身はいじれない　　　.Sort key1:=.Cells(1, 2), order1:=xlAscending, _ 　　　　key2:=.Cells(1, 1), order2:=xlAscending, _ 　　　　Header:=xlYes, MatchCase:=False, _ 　　　　Orientation:=xlTopToBottom 　　End With 　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　'ダフリを消す　　For i = lastRow To stRow + 1 Step -1 'midRow 　　　If .Cells(i, 1).Value <> "" Then 　　　　If .Cells(i, 1).Value & .Cells(i, 2).Value = .Cells(i - 1, 1).Value & .Cells(i - 1, 2).Value Then 　　　　　If .Cells(i - 1, lastCol).Value = "" Then 　　　　　　.Range(.Cells(i, st2Col), .Cells(i, lastCol)).Copy .Cells(i - 1, st2Col) 　　　　　　.Rows(i).EntireRow.Delete 　　　　　End If 　　　　End If 　　　End If 　　Next i 　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row 　　midRow = .Cells(lastRow, 1).End(xlUp).Row 　　lastCol2 = .Cells(stRow2, Columns.Count).End(xlToLeft).Column 　　.Cells(1, 1).Value = "表Ⅲ" 　　'罫線をつける替える　　.Range(.Cells(stRow2, 1), .Cells(maxRow, lastCol)).Borders.LineStyle = xlNone 　　.Range(.Cells(stRow2, 1), .Cells(lastRow, lastCol)).Borders.LineStyle = xlContinuous 　　Application.ScreenUpdating = True 　　Sh2.Select 　End With 　MsgBox "終了", vbInformation End Sub

WindFaller · Answer

こんにちは。しばらくやってみて、この表の作り方って、ものすごく単純な造りだということが分かりました。難しく考えすぎでした。販売・仕入れ・経理の表は慣れているのですが、ただ、どうして、このような表を作り、何がわかるのか、製造の実務を知らない私には、この表の意味が分かりません。余計なお世話ではあるのですが。VBA入門以前の技術を使いました。根気さえあれば、誰でもできる内容です。なお、同じシートに出力するようになっています。別シートに出すためには、もう一捻り必要です。 No.3 さんのDictionary オブジェクトを使うマクロは、最初に考えたのですが、私の考えたのは矛盾が出来て納得できなかったのです。今回は、初期の技術を使ったマクロです。設定： st2Col = 7 '表Ⅱの開始列-G列　ここが大事表を2分する境目です。ここさえ間違いなければ、できあがるはずです。 '// Sub Consolidate3() 　Dim Sh1 As Worksheet 　Dim Rng1 As Range 'ソートの範囲　Dim st2Col As Long '第2表の始まり列　Dim stRow As Long 'スタート行　Dim lastCol As Long, lastRow As Long, endRow As Long 　Dim midRow As Long, maxRow As Long, dist As Long 　Dim i As Long 　Set Sh1 = ActiveSheet 'シートの設定(アクティブシート) 　With Sh1 　　lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column '2行目がタイトル行　　If lastCol < 4 Then MsgBox "表の設定が違うようです。", vbExclamation: Exit Sub 　　'--------ユーザー設定------------- 　　st2Col = 7 '表Ⅱの開始列-G列　　stRow = 3 'スタート行(今は使っていない) 　　dist = 3 'もと表からの作成表の行間　　maxRow = 500 '最大使用行(特に変更する必要はない) 　　'---------------------------------- 　　'前のデータの消去　　midRow = .Cells(3, 1).End(xlDown).Row '中間行　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row '最終行　　If lastRow > midRow Then 　　　lastRow = .Cells(midRow, 1).End(xlDown).Row ' 　　　.Range(.Cells(lastRow, 1), .Cells(maxRow, lastCol + 100)).Clear '既作成表の削除　　　'(もし、残骸が残るようなら、lastCol + 100 などとしてください。) 　　End If 　　midRow = midRow + dist '作成表の開始位置　　lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column 　　.Range(.Cells(2, 1), .Cells(2, st2Col - 1)).Copy .Cells(midRow, 1) 　　.Range(.Cells(2, st2Col + 2), .Cells(2, lastCol)).Copy .Cells(midRow, st2Col) 　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　.Range("A3", .Cells(midRow - 3, st2Col - 1)).Copy .Cells(lastRow + 1, 1) 　　lastCol = .Cells(3, Columns.Count).End(xlToLeft).Column 　　endRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　midRow = .Cells(3, st2Col).End(xlDown).Row '二分した表の次の表　　.Range(.Cells(3, st2Col), .Cells(midRow, st2Col + 1)).Copy .Cells(endRow + 1, 1) 　　.Range(.Cells(3, st2Col + 2), .Cells(midRow, lastCol)).Copy .Cells(endRow + 1, st2Col) 　　midRow = .Cells(midRow, 1).End(xlDown).Row '* 　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row '* 　　Set Rng1 = .Range(.Cells(midRow + 3, 1), .Cells(lastRow, lastCol)) 　　Application.ScreenUpdating = False 　　With Rng1 　　　.Sort key1:=.Cells(1, 2), order1:=xlAscending, _ 　　　　key2:=.Cells(1, 1), order2:=xlAscending, _ 　　　　Header:=xlYes, MatchCase:=False, _ 　　　　Orientation:=xlTopToBottom 　　End With 　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　'ダフリを消す　　For i = lastRow To midRow Step -1 　　　If .Cells(i, 1).Value <> "" Then 　　　　If .Cells(i, 1).Value & .Cells(i, 2).Value = .Cells(i - 1, 1).Value & .Cells(i - 1, 2).Value Then 　　　　　If .Cells(i - 1, lastCol - 2).Value = "" Then 　　　　　　.Range(.Cells(i, st2Col), .Cells(i, lastCol - 2)).Copy .Cells(i - 1, st2Col) 　　　　　　.Rows(i).EntireRow.Delete 　　　　　End If 　　　　End If 　　　End If 　　Next i 　　lastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　midRow = .Cells(lastRow, 1).End(xlUp).Row 　　.Range(.Cells(midRow, 1), .Cells(lastRow, lastCol - 2)).Borders.LineStyle = xlContinuous 　　Application.ScreenUpdating = True 　End With 　'MsgBox "終了", vbInformation '動くようなら、コメントブロックを外してください。 End Sub

tom04 · Answer

No.2です。

どうも失礼しました。
結局Sheet1のA・B・K列とG・H・K列の重複の重複を判断すれば良いのでしょうかね。

前回のコードは消去し↓のコードに変更してみてください。

Sub Sample2()
　Dim myDic As Object
　Dim i As Long, j As Long, lastRow As Long
　Dim myStr As String, wS As Worksheet
　Dim myKey, myItem, myR, myAry1, myAry2
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:I").ClearContents
　　　With Worksheets("Sheet1")
　　　　wS.Range("A1:F1").Value = .Range("A1:F1").Value
　　　　wS.Range("G1:I1").Value = .Range("I1:K1").Value
　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "K"))
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 11)
　　　　　　　　myDic.Add myStr, myR(i, 3) & "_" & myR(i, 4) & "_" & myR(i, 5) & "_" & myR(i, 6)
　　　　　　　Next i
　　　　　lastRow = .Cells(Rows.Count, "G").End(xlUp).Row
　　　　　　myR = Range(.Cells(2, "G"), .Cells(lastRow, "K"))
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 5)
　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　myDic.Add myStr, "" & "_" & "" & "_" & "" & "_" & "" & "_" & myR(i, 3) & "_" & myR(i, 4) & "_" & myR(i, 5)
　　　　　　　　　Else
　　　　　　　　　　myDic(myStr) = myDic(myStr) & "_" & myR(i, 3) & "_" & myR(i, 4) & "_" & myR(i, 5)
　　　　　　　　　End If
　　　　　　　Next i
　　　End With
　　　　myKey = myDic.keys
　　　　myItem = myDic.items
　　　　　myR = Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "I"))
　　　　　　For i = 0 To UBound(myKey)
　　　　　　　myAry1 = Split(myKey(i), "_")
　　　　　　　　myR(i + 1, 1) = myAry1(0)
　　　　　　　　myR(i + 1, 2) = myAry1(1)
　　　　　　　myAry2 = Split(myItem(i), "_")
　　　　　　　　For j = 0 To UBound(myAry2)
　　　　　　　　　myR(i + 1, j + 3) = myAry2(j)
　　　　　　　　Next j
　　　　　　Next i
　　　　　Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "I")) = myR
　　　　Set myDic = Nothing
　　　　wS.Range("A1").CurrentRegion.Sort _
　　　　　key1:=wS.Range("A1"), order1:=xlAscending, _
　　　　　key2:=wS.Range("B1"), order1:=xlAscending, Header:=xlYes
　　　　wS.Activate
　　　MsgBox "完了"
End Sub

※　A・B列内またはG・H列内での重複はない！という前提です。

※　細かい検証はしていませんので
お望みどおりにならなかったらごめんなさい。m(_ _)m

tom04 · Answer

こんばんは！元データはSheet1にあり、Sheet2に表示するとします。尚、お示しの画像は1行目は説明文になっていますが、実際のデータは1行目が項目行でデータは2行目以降にあるという前提です。一例です。標準モジュールにしてください。 Sub Sample1() 　Dim i As Long, lastRow As Long, cnt As Long 　　Application.ScreenUpdating = False 　　　With Worksheets("Sheet2") 　　　　Worksheets("Sheet1").Range("A:K").Copy .Range("A1") 　　　　　lastRow = .UsedRange.Rows.Count 　　　　　　For i = 2 To lastRow 　　　　　　　If .Cells(i, "A") <> "" And .Cells(i, "G") <> "" Then 　　　　　　　　If .Cells(i, "A") > .Cells(i, "G") Then 　　　　　　　　　Do 　　　　　　　　　　cnt = cnt + 1 　　　　　　　　　　Range(.Cells(i, "A"), .Cells(i, "F")).Insert shift:=xlDown 　　　　　　　　　　If .Cells(i + cnt, "A") <= .Cells(i + cnt, "G") Then Exit Do 　　　　　　　　　Loop 　　　　　　　　　　lastRow = lastRow + cnt 　　　　　　　　ElseIf .Cells(i, "A") < .Cells(i, "G") Then 　　　　　　　　　Do 　　　　　　　　　　cnt = cnt + 1 　　　　　　　　　　Range(.Cells(i, "G"), .Cells(i, "K")).Insert shift:=xlDown 　　　　　　　　　　If .Cells(i + cnt, "A") >= .Cells(i + cnt, "G") Then Exit Do 　　　　　　　　　Loop 　　　　　　　　　　lastRow = lastRow + cnt 　　　　　　　　End If 　　　　　　　End If 　　　　　　　　cnt = 0 　　　　　　Next i 　　　　　　For i = 2 To lastRow 　　　　　　　If .Cells(i, "A") = "" Then 　　　　　　　　.Cells(i, "A").Resize(, 2).Value = .Cells(i, "G").Resize(, 2).Value 　　　　　　　End If 　　　　　　Next i 　　　　　.Range("G:H").Delete 　　　　　.Activate 　　　End With 　　Application.ScreenUpdating = True 　　　MsgBox "完了" End Sub ※　当方の解釈が間違っているかもしれませんが、お示しの画像では⑤が2行になっていますが、上記マクロを実行すると⑤の行が1行になります。m(_ _)m

WindFaller · Answer

こんばんは。

この表で分からないところがありますね。
表I と表II で、三つ出てきていますが、
②　B   6
②　B   12 ,19, W
②　B   17, X
合算表では、これは、2つに別けているようです。
本当は、一緒にしてしまって、その中にダブりがあれば、足してしまったほうが楽なのですが。
そうでない場合は、B'とするしかなくなるのではないかと思っています。

この場で見ているよりも、いろんなケースが出てきそうな気がします。

2つの表が隣り合わせというのは、イレギュラーでややこしいです。
項目名が、20個というのは、どのような割り振りなのか、それ自体を探すのか、それも分からないところがあります。10 個、10個なのか、つまり、C列から10列目L列と、
M列=製造番号,　N列=品名　O列から10列目X列まで。

今の段階では、値は、数値と文字と明確に分かれているものとします。データベース出力の場合に、数値が数値として認識しない時があります。

エクセルのマクロについて教えて下さい！

>1901-002『か』のデータが1812-003『う』のデータに変わっていて、

改良点・変更点：

遅くなって申し訳ないです。

>同じ製造番号で品名Bが、例えば費用aと費用ｃに別々に費用があった場合（作業した日が違うので行が別）

No.4 の回答者です。

こんにちは。

No.2です。

こんばんは！

こんばんは。

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング