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

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


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


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

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

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

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

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

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

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

1520410082
●拡大する

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

▽最新の回答へ

質問者から

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


1 ● Z1000S
●400ポイント ベストアンサー

こんな感じですかね


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


naranara19さんのコメント
早速ありがとうございます!ほとんど良いのですが、「定」の文字のものだけ、同じ住所の塊になったときに、定の文字群の中で一番下にいきません。また、一番下の方にあるはずの「ゆ」がなぜか上の方にすべてあがってしまうのですが、これは仕方ないでしょうか。

Z1000Sさんのコメント
>「定」の文字のものだけ、同じ住所の塊になったときに、定の文字群の中で一番下にいきません。 状況が理解できませんので、回答は出来ません。具体的な例を示していただければ対処できるかもしれません。 >また、一番下の方にあるはずの「ゆ」がなぜか上の方にすべてあがってしまうのですが、これは仕方ないでしょうか。 「発送」の文字の(上下の)順番については、特に明記されていないようでしたので、提示したコードでは、「発送」の1文字目を基準に昇順に並べ替えてグループに纏める処理としてあります。 '「発送」の先頭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 の部分で並び替え用のデータを設定し .Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, 2), ws.Cells(lEndRow, 2)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal の部分で並べ替えの指示をしています。 「発送」の文字の(上下の)順番に指定があるのであれば、上記のタイミングで、B列に設定する値を「希望する順番に並ぶようにセットする」よう変更すれば大丈夫かと思います。 ただ、こちらでは 「発送」の部分に入る文字列が予め決まっているのかとか、その場合、特定の順番にすればいいのか?とか それとも、元データによって並びの順番が変わってくるのか?とか そういった並びの順番に関するルールが全くわかりませんので・・・

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

Z1000Sさんのコメント
ややこしいかどうかは、仕様さえ「しっかり」まとまっていれば、あまり問題はないです。 ただ、その「しっかり」というのが難しいのですけどね。 でも「しっかり」伝えないと、自分が欲しい物は手に入らないですよ。 時間やコストの無駄にもなりますし。 今回の処理自体は、シート1枚の中のデータで収まっていますし、 それほど難しい処理ではないと思いますよ。 最後に保留となった並べ替えも、おそらくそれ程難しい処理ではないような気がします。 投稿された時刻を見ていると、大変そうだなと感じてます。 頑張ってくださいね。 以下、余談 もし、元のデータがデータベースに入っているのであれば データベース側で数回のSQLの実行で、かなり今回の最終型に近い物ができるかもしれません。
関連質問

●質問をもっと探す●



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