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



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


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

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

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

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

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

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

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

回答の条件
  • 1人1回まで
  • 13歳以上
  • 登録:2018/02/28 06:49:23
  • 終了:2018/03/07 06:50:04
id:naranara19

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

回答(0件)

回答はまだありません

  • id:Z1000S
    回答期間が今朝で終了しているようなので、非公式回答としてこちらに。
    100%ご要望通りではないかもしれませんが・・・

    参考用としてなので、問い合わせは無しという事でお願いします。
    解析して、適当にいじってみてください。

    こちらのコメント欄は、preタグ、codeタグが使えないようなので
    インデントが無くなって見づらいとは思いますが、そこは仕様ということで了承ください。

    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)

    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:=Range("F2:F21"), 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
  • id:naranara19
    ありがとうございます!!回答期限が過ぎていて失礼いたしました。ちょっとやってみましたら、動くのですが、佐・定・順番がばらばらになったようでした。佐なら、佐の文字列があるなかで一番下に、定ならば、先頭の定の文字のある中で一番したになってほしいのですが、それがバラバラになっていたということです。再度時間をつくって新しく質問をたててリクエストしますね。そのときに今回のコメントの回答分もあわせてポイントをお支払いたします。本当にありがとうございます。
  • id:naranara19
    【1】佐・定・順番がばらばらになったようでした。

    という以外に、


    【2】
    佐 961 0 - 一山一郎
    佐 399 0 - 一山一郎
    佐 334 0 - 一山一郎
    佐 108 0 - 一山一郎
    佐 374 0 - 一山一郎
    佐 118 0 - 一山一郎
    佐 270 0 - 一山一郎
    佐 179 400 - 一山一郎
    佐 441 400 - 一山一郎
    佐 853 600 - 一山一郎
    佐 518 140 - 一山一郎
    佐 540 164 - 一山一郎
    佐 136 250 - 一山一郎
    佐 1,384 0 - 一山一郎
    佐 108 120 - 一山一郎
    佐 384 680 7,787 一山一郎


    ↑こうなっているところ、処理すると、

    佐 961 0 - 一山一郎
    佐2 一山一郎
    佐3 一山一郎
    佐4 一山一郎
    佐5 一山一郎
    佐6 一山一郎
    佐7 一山一郎
    佐8 一山一郎
    佐9 一山一郎
    佐10 一山一郎
    佐11 一山一郎
    佐12 一山一郎
    佐13 一山一郎
    佐14 一山一郎
    佐15 一山一郎
    佐16 一山一郎

    このようになりました。7787だけは表示されて、
    佐 961 0 7787 一山一郎

    となってほしいのです。
    それでは同じものを立ててリクエストいたします。

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

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

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

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