1520410082 エクセルマクロVBA 住所リストの行列を操作したい Add Star



同じ出荷先があったとき、セルの入替をマクロでお願いしたいのです。


※画像をご確認ください(太字にご注目)

【ルール】
I列に住所があります。
(同じ住所がバラバラにおいてあることはなく、必ず連続しておいてあります)

同じ住所があるときにはE列の数字で一番大きなものを親の行として、
同じ住所内の先頭に列ごと切り取って挿入します。
(数字ではなく-のように記号などが入っていることがあります)

そして、同じ住所群があったときには親の行以外のC、D、E列をすべて空白にします。
また、親の行のB列の一文字目の言葉+半角で数字をつけていってください。親の行のBの値だけはそのままです(画像参照)

さらには、同じ住所が続く塊をB列の1文字目(必ず漢字かひらがな、片仮名です)を基準として並び替えを行い、
その中の一番下の位置に行ごと切り取って配置したいのです。

★細かい条件がありますので、コメントとして追記いたしますので、必ずご確認ください。

エクセルVBAでの回答のみ、ポイント申請の対象とさせていただきます。

回答の条件
  • 1人1回まで
  • 13歳以上
  • 登録:2018/03/07 17:08:01
  • 終了:2018/03/09 04:14:42
id:naranara19

※半角数字をつけるのは必ず親を除く半角「2」からで親の行を含む合計の住所が11個あるならば、2~11までがつくということになります。
※I列が空白になったところが処理の終了位置です。
※並び替えは必ず行ごと行います(K列以降もデータが入っているからです)
※親番号以外の行の順序は、特に指定はありません。
※数字はC、Dは適当に入れていますので、無視してください
※同じ住所群でもB列の1文字目が異なることがあります。その場合は親の行になるものを基準としてデータを操作します(※二十二十郎さんがそれにあたります)
※同じ住所群が下の方にうつしますが、その塊同士での順序は特に指定はありません。

ベストアンサー

id:Z1000S No.1

Z1000S回答回数30ベストアンサー獲得回数212018/03/07 19:41:22

ポイント400pt

こんな感じですかね


Option Explicit

Private Const SHIPMENT_COL As Long = 2

Private Const WINNING_BID_COL As Long = 3

Private Const TOTAL_COL As Long = 5

Private Const ADDRESS_COL As Long = 9

Private Const HEADER_ROWS As Long = 1


Public Sub sortByMyRule()

Const TARGET_SHEET_NAME As String = "Sheet1"

Dim ws As Worksheet
Dim lEndRow As Long

'処理対象ワークシート
Set ws = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)

'住所列の最終行取得
lEndRow = ws.Cells(1, ADDRESS_COL).End(xlDown).Row

'住所と計で並べ替え
Call sortByAddressAndTotal(ws, lEndRow)

'「発送」への番号付与、「落札」「送料」「計」クリア
Call editItemValue(ws, lEndRow)

'「発送」をグループ化するため再度並べ替え
Call groupByShipment(ws, lEndRow)

Set ws = Nothing

End Sub

Private Sub sortByAddressAndTotal(ByRef ws As Worksheet, ByVal lEndRow As Long)

'「計」補正用列挿入
ws.Columns(TOTAL_COL + 1).Insert

'「計」での並べ替え用補正値の計算式設定
With ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1)
.FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1],0)"
.AutoFill Destination:=ws.Range(ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1), ws.Cells(lEndRow, TOTAL_COL + 1)), Type:=xlFillDefault
End With

'並べ替え
With ws.Sort
With .SortFields
.Clear
'計補正用列があるため、並べ替えの基準列を1オフセットする
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, ADDRESS_COL + 1), ws.Cells(lEndRow, ADDRESS_COL + 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1), ws.Cells(lEndRow, TOTAL_COL + 1)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With

.SetRange ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, ws.Columns.Count))
.Apply
End With

'「計」補正用列削除
ws.Columns(TOTAL_COL + 1).Delete

End Sub

Private Sub editItemValue(ByRef ws As Worksheet, ByVal lEndRow As Long)

Dim lCurrentRow As Long
Dim lBeginRow As Long
Dim sCurrentAddress As String
Dim lItems As Long
Dim sPrefix As String
Dim i As Long

lCurrentRow = HEADER_ROWS + 1

lBeginRow = lCurrentRow

With ws
Do Until lCurrentRow > lEndRow
sCurrentAddress = .Cells(lCurrentRow, ADDRESS_COL).Value

lItems = 1

Do While (sCurrentAddress = .Cells(lCurrentRow + lItems, ADDRESS_COL).Value)
lItems = lItems + 1
Loop

If lItems > 1 Then
sPrefix = Left$(.Cells(lBeginRow, SHIPMENT_COL).Value, 1)

For i = 1 To lItems - 1
'発送へ番号付与
.Cells(lBeginRow + i, SHIPMENT_COL).Value = sPrefix & CStr(i + 1)
Next i

'落札、送料、計クリア
.Range(.Cells(lBeginRow + 1, WINNING_BID_COL), .Cells(lBeginRow + lItems - 1, TOTAL_COL)).ClearContents
End If

lCurrentRow = lCurrentRow + lItems

lBeginRow = lCurrentRow
Loop
End With

End Sub

Private Sub groupByShipment(ByRef ws As Worksheet, ByVal lEndRow As Long)

With ws
'「発送」グループ化用データ列挿入
.Columns(1).Insert
.Columns(1).Insert

'現在の並び順の番号を生成
.Cells(HEADER_ROWS + 1, 1) = 1
.Cells(HEADER_ROWS + 2, 1) = 2

.Range(.Cells(HEADER_ROWS + 1, 1), .Cells(HEADER_ROWS + 2, 1)).AutoFill Destination:=.Range(.Cells(HEADER_ROWS + 1, 1), .Cells(lEndRow, 1)), Type:=xlFillDefault

'「発送」の先頭1文字抽出
.Cells(HEADER_ROWS + 1, 2).FormulaR1C1 = "=LEFT(RC[2],1)"
.Cells(HEADER_ROWS + 1, 2).AutoFill Destination:=.Range(.Cells(HEADER_ROWS + 1, 2), .Cells(lEndRow, 2)), Type:=xlFillDefault
End With

'並べ替え
With ws.Sort
With .SortFields
.Clear
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, 2), ws.Cells(lEndRow, 2)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With

.SetRange ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, ws.Columns.Count))
.Apply
End With

'「発送」グループ化用データ列削除
ws.Columns(2).Delete
ws.Columns(1).Delete

End Sub

他2件のコメントを見る
id:naranara19

ありがとうございます。他の方のコメントにもありましたが、ちょっとややこしいですし、無駄も確かにありそうでして、今回はこれで終わりますね。本当にありがとうございました!感謝いたします。

2018/03/09 04:09:41
id:Z1000S

ややこしいかどうかは、仕様さえ「しっかり」まとまっていれば、あまり問題はないです。
ただ、その「しっかり」というのが難しいのですけどね。
でも「しっかり」伝えないと、自分が欲しい物は手に入らないですよ。
時間やコストの無駄にもなりますし。

今回の処理自体は、シート1枚の中のデータで収まっていますし、
それほど難しい処理ではないと思いますよ。
最後に保留となった並べ替えも、おそらくそれ程難しい処理ではないような気がします。

投稿された時刻を見ていると、大変そうだなと感じてます。
頑張ってくださいね。

以下、余談
もし、元のデータがデータベースに入っているのであれば
データベース側で数回のSQLの実行で、かなり今回の最終型に近い物ができるかもしれません。

2018/03/09 21:26:28

その他の回答(0件)

id:Z1000S No.1

Z1000S回答回数30ベストアンサー獲得回数212018/03/07 19:41:22ここでベストアンサー

ポイント400pt

こんな感じですかね


Option Explicit

Private Const SHIPMENT_COL As Long = 2

Private Const WINNING_BID_COL As Long = 3

Private Const TOTAL_COL As Long = 5

Private Const ADDRESS_COL As Long = 9

Private Const HEADER_ROWS As Long = 1


Public Sub sortByMyRule()

Const TARGET_SHEET_NAME As String = "Sheet1"

Dim ws As Worksheet
Dim lEndRow As Long

'処理対象ワークシート
Set ws = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)

'住所列の最終行取得
lEndRow = ws.Cells(1, ADDRESS_COL).End(xlDown).Row

'住所と計で並べ替え
Call sortByAddressAndTotal(ws, lEndRow)

'「発送」への番号付与、「落札」「送料」「計」クリア
Call editItemValue(ws, lEndRow)

'「発送」をグループ化するため再度並べ替え
Call groupByShipment(ws, lEndRow)

Set ws = Nothing

End Sub

Private Sub sortByAddressAndTotal(ByRef ws As Worksheet, ByVal lEndRow As Long)

'「計」補正用列挿入
ws.Columns(TOTAL_COL + 1).Insert

'「計」での並べ替え用補正値の計算式設定
With ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1)
.FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1],0)"
.AutoFill Destination:=ws.Range(ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1), ws.Cells(lEndRow, TOTAL_COL + 1)), Type:=xlFillDefault
End With

'並べ替え
With ws.Sort
With .SortFields
.Clear
'計補正用列があるため、並べ替えの基準列を1オフセットする
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, ADDRESS_COL + 1), ws.Cells(lEndRow, ADDRESS_COL + 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1), ws.Cells(lEndRow, TOTAL_COL + 1)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With

.SetRange ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, ws.Columns.Count))
.Apply
End With

'「計」補正用列削除
ws.Columns(TOTAL_COL + 1).Delete

End Sub

Private Sub editItemValue(ByRef ws As Worksheet, ByVal lEndRow As Long)

Dim lCurrentRow As Long
Dim lBeginRow As Long
Dim sCurrentAddress As String
Dim lItems As Long
Dim sPrefix As String
Dim i As Long

lCurrentRow = HEADER_ROWS + 1

lBeginRow = lCurrentRow

With ws
Do Until lCurrentRow > lEndRow
sCurrentAddress = .Cells(lCurrentRow, ADDRESS_COL).Value

lItems = 1

Do While (sCurrentAddress = .Cells(lCurrentRow + lItems, ADDRESS_COL).Value)
lItems = lItems + 1
Loop

If lItems > 1 Then
sPrefix = Left$(.Cells(lBeginRow, SHIPMENT_COL).Value, 1)

For i = 1 To lItems - 1
'発送へ番号付与
.Cells(lBeginRow + i, SHIPMENT_COL).Value = sPrefix & CStr(i + 1)
Next i

'落札、送料、計クリア
.Range(.Cells(lBeginRow + 1, WINNING_BID_COL), .Cells(lBeginRow + lItems - 1, TOTAL_COL)).ClearContents
End If

lCurrentRow = lCurrentRow + lItems

lBeginRow = lCurrentRow
Loop
End With

End Sub

Private Sub groupByShipment(ByRef ws As Worksheet, ByVal lEndRow As Long)

With ws
'「発送」グループ化用データ列挿入
.Columns(1).Insert
.Columns(1).Insert

'現在の並び順の番号を生成
.Cells(HEADER_ROWS + 1, 1) = 1
.Cells(HEADER_ROWS + 2, 1) = 2

.Range(.Cells(HEADER_ROWS + 1, 1), .Cells(HEADER_ROWS + 2, 1)).AutoFill Destination:=.Range(.Cells(HEADER_ROWS + 1, 1), .Cells(lEndRow, 1)), Type:=xlFillDefault

'「発送」の先頭1文字抽出
.Cells(HEADER_ROWS + 1, 2).FormulaR1C1 = "=LEFT(RC[2],1)"
.Cells(HEADER_ROWS + 1, 2).AutoFill Destination:=.Range(.Cells(HEADER_ROWS + 1, 2), .Cells(lEndRow, 2)), Type:=xlFillDefault
End With

'並べ替え
With ws.Sort
With .SortFields
.Clear
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, 2), ws.Cells(lEndRow, 2)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With

.SetRange ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, ws.Columns.Count))
.Apply
End With

'「発送」グループ化用データ列削除
ws.Columns(2).Delete
ws.Columns(1).Delete

End Sub

他2件のコメントを見る
id:naranara19

ありがとうございます。他の方のコメントにもありましたが、ちょっとややこしいですし、無駄も確かにありそうでして、今回はこれで終わりますね。本当にありがとうございました!感謝いたします。

2018/03/09 04:09:41
id:Z1000S

ややこしいかどうかは、仕様さえ「しっかり」まとまっていれば、あまり問題はないです。
ただ、その「しっかり」というのが難しいのですけどね。
でも「しっかり」伝えないと、自分が欲しい物は手に入らないですよ。
時間やコストの無駄にもなりますし。

今回の処理自体は、シート1枚の中のデータで収まっていますし、
それほど難しい処理ではないと思いますよ。
最後に保留となった並べ替えも、おそらくそれ程難しい処理ではないような気がします。

投稿された時刻を見ていると、大変そうだなと感じてます。
頑張ってくださいね。

以下、余談
もし、元のデータがデータベースに入っているのであれば
データベース側で数回のSQLの実行で、かなり今回の最終型に近い物ができるかもしれません。

2018/03/09 21:26:28
  • id:smithy250
    通販やってることわかるけど、なんでそんな処理が必要なのよ。無駄な仕事多すぎない?
    毎回VBAを要求するのもどうかと思うよ。データを致命的に削除するVBA貼られたとして、あんた判別できないんでしょ?
    自分で勉強すること覚えれば?
  • id:naranara19
    自分で覚えなおしているところではあります。スキルが足りない分、できる方にお願いしているのです。
    コストをかけて聞ける「はてな」は知恵袋などと違って感謝をポイントとしてお渡しできるのでありがたい存在なのです。

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

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

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

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