id:moon-fondu
ポイントあり1100ptベストアンサーあり
コンピュータ学習・教育

2～4つの文字数バラバラの単語で構成される文字列を並べ替える方法につきまして

今、A列に次のような文字列が10000行近く、ずらりと並んでおります。

単語A★単語B★単語C■
単語D★単語E★単語F★単語G■
単語H★単語I■
単語J★単語K★単語L■
単語M★単語N■
単語O★単語P★単語Q★単語R■
・
・
・

1つのセルは2～4つの単語の文字列が入っております。
それぞれの単語自体はバラバラで特に規則性はないです。
単語と単語の間に★印があり、最後の単語の後ろには■がくっ付いております。
上記の状態から、

単語C■単語A★単語B★
単語G■単語D★単語E★単語F★
単語I■単語H★
単語L■単語J★単語K★
単語N■単語M★
単語R■単語O★単語P★単語Q★
・
・
・

と、並べ替えを行いたいのです。
量が多くて困っているのですが・・・何かよい並べ替えのマクロや関数等ありましたら、
お教えいただけないでしょうか。

よろしくお願い致します。

回答の条件
  • 1人5回まで
  • 登録：
  • 終了：2015/11/05 01:26:30
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:a-kuma3 No.1

回答回数4973ベストアンサー獲得回数2154

ポイント1000pt

マクロですが、こんな感じで。

Sub change_data()
    COL_POS = 1         ' A列
    ROW_START = 1
    ROW_END = 10000

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^(.*★)(.*■)$"
    For i = ROW_START To ROW_END
        Set c = Cells(i, COL_POS)
        If IsEmpty(c) Or c.Value = "" Then
            Exit For
        End If
        Set remat = re.Execute(c.Value)
        If remat.Count > 0 Then
            s1 = remat(0).SubMatches(0)
            s2 = remat(0).SubMatches(1)
            c.Value = s2 & s1
        End If
        DoEvents
    Next
End Sub

A列を ROW_START 行から、ROW_END の行まで処理します。
途中、空のセルがあれば、そこで処理を中止するようにしてます。



追記です。
式でもやってみました。

=RIGHT(A1,LEN(A1)-FIND("＠＠＠",SUBSTITUTE(A1,"★","＠＠＠",LEN(A1) - LEN(SUBSTITUTE(A1,"★","")))))&LEFT(A1,FIND("＠＠＠",SUBSTITUTE(A1,"★","＠＠＠",LEN(A1) - LEN(SUBSTITUTE(A1,"★","")))))

式の中に何度か出てくる "＠＠＠" はどんな文字列でも良いんですが、セルの中に絶対に出てこない文字列です。
この式を、1行目のどこかの列に入力して、下方向に必要な数だけコピーしてください。


マクロの方が簡単です　(´・ω・｀)
もし、どうしても関数でやりたいとしたら、VBA でユーザ定義関数を書いて、それを使った方が簡単（メンテが楽）だと思います。



追記です。

空白セルはスキップして並べ替えることが出来るマクロの方をお教えいただきますでしょうか。

空白セルで処理を止めるところを削除しました。
指定した行数だけ処理します。

Sub change_data()
    COL_POS = 1         ' A列
    ROW_START = 1
    ROW_END = 10000

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^(.*★)(.*■)$"
    For i = ROW_START To ROW_END
        Set c = Cells(i, COL_POS)
        Set remat = re.Execute(c.Value)
        If remat.Count > 0 Then
            s1 = remat(0).SubMatches(0)
            s2 = remat(0).SubMatches(1)
            c.Value = s2 & s1
        End If
        DoEvents
    Next
End Sub
他1件のコメントを見る
id:a-kuma3

空白セルはスキップして並べ替えることが出来るマクロの方をお教えいただきますでしょうか。

回答に追記しました。
空白のセルが出てくるところまでは、きちんと処理できてますよね？

2015/11/03 19:00:28
id:moon-fondu

すごいです、ありがとうございます。
空白セルありましたが、一瞬で変わりました！

2015/11/05 01:24:39

その他の回答（1件）

id:a-kuma3 No.1

回答回数4973ベストアンサー獲得回数2154ここでベストアンサー

ポイント1000pt

マクロですが、こんな感じで。

Sub change_data()
    COL_POS = 1         ' A列
    ROW_START = 1
    ROW_END = 10000

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^(.*★)(.*■)$"
    For i = ROW_START To ROW_END
        Set c = Cells(i, COL_POS)
        If IsEmpty(c) Or c.Value = "" Then
            Exit For
        End If
        Set remat = re.Execute(c.Value)
        If remat.Count > 0 Then
            s1 = remat(0).SubMatches(0)
            s2 = remat(0).SubMatches(1)
            c.Value = s2 & s1
        End If
        DoEvents
    Next
End Sub

A列を ROW_START 行から、ROW_END の行まで処理します。
途中、空のセルがあれば、そこで処理を中止するようにしてます。



追記です。
式でもやってみました。

=RIGHT(A1,LEN(A1)-FIND("＠＠＠",SUBSTITUTE(A1,"★","＠＠＠",LEN(A1) - LEN(SUBSTITUTE(A1,"★","")))))&LEFT(A1,FIND("＠＠＠",SUBSTITUTE(A1,"★","＠＠＠",LEN(A1) - LEN(SUBSTITUTE(A1,"★","")))))

式の中に何度か出てくる "＠＠＠" はどんな文字列でも良いんですが、セルの中に絶対に出てこない文字列です。
この式を、1行目のどこかの列に入力して、下方向に必要な数だけコピーしてください。


マクロの方が簡単です　(´・ω・｀)
もし、どうしても関数でやりたいとしたら、VBA でユーザ定義関数を書いて、それを使った方が簡単（メンテが楽）だと思います。



追記です。

空白セルはスキップして並べ替えることが出来るマクロの方をお教えいただきますでしょうか。

空白セルで処理を止めるところを削除しました。
指定した行数だけ処理します。

Sub change_data()
    COL_POS = 1         ' A列
    ROW_START = 1
    ROW_END = 10000

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^(.*★)(.*■)$"
    For i = ROW_START To ROW_END
        Set c = Cells(i, COL_POS)
        Set remat = re.Execute(c.Value)
        If remat.Count > 0 Then
            s1 = remat(0).SubMatches(0)
            s2 = remat(0).SubMatches(1)
            c.Value = s2 & s1
        End If
        DoEvents
    Next
End Sub
他1件のコメントを見る
id:a-kuma3

空白セルはスキップして並べ替えることが出来るマクロの方をお教えいただきますでしょうか。

回答に追記しました。
空白のセルが出てくるところまでは、きちんと処理できてますよね？

2015/11/03 19:00:28
id:moon-fondu

すごいです、ありがとうございます。
空白セルありましたが、一瞬で変わりました！

2015/11/05 01:24:39
id:rsc96074 No.2

回答回数4503ベストアンサー獲得回数437

ポイント100pt

　上の方より、単純でレベル低いですが、こちらはいかがでしょうか。
　InStrRev関数を使ってみました。テストのため「ROW_END = 6」にしてありますので変えてみてください。

Option Explicit

Sub change_data()
    Dim n As Integer: n = 0
    Dim s As String: s = ""
    Dim i As Integer
    
    Dim COL_POS, ROW_START, ROW_END As Integer
    COL_POS = 1        ' A列
    ROW_START = 1
    ROW_END = 6
     
    For i = ROW_START To ROW_END
        s = Cells(i, COL_POS).Value
        If IsEmpty(Cells(i, COL_POS)) Or s = "" Then Exit For
        n = InStrRev(s, "★")
        If n = 0 Then Exit For
        Cells(i, COL_POS).Value = Mid(s, n + 1) & Left(s, n)
        DoEvents
    Next
End Sub

※参考URL
●Office TANAKA - Excel VBA関数[InStrRev関数]
http://officetanaka.net/excel/vba/function/InStrRev.htm

他1件のコメントを見る
id:rsc96074

　こんな感じでMsgBoxでエラー行を調べてみるといいかも知れません。(^_^;

Option Explicit

Sub change_data()
    Dim n As Integer: n = 0
    Dim s As String: s = ""
    Dim i As Integer
    
    Dim COL_POS, ROW_START, ROW_END As Integer
    COL_POS = 1        ' A列
    ROW_START = 1
    ROW_END = 6
     
    For i = ROW_START To ROW_END
        s = Cells(i, COL_POS).Value
        If IsEmpty(Cells(i, COL_POS)) Or s = "" Then
            MsgBox i
            Exit For
        End If
        n = InStrRev(s, "★")
        If n = 0 Then
            MsgBox i
            Exit For
        End If
        Cells(i, COL_POS).Value = Mid(s, n + 1) & Left(s, n)
        DoEvents
    Next
End Sub
2015/11/05 06:56:40
id:moon-fondu

rscさんご回答ありがとうございます！
1行目がエラーであることが判りました！
見出しとして、普通の文字列を入れていましたね。

2015/11/11 04:58:04

コメント（1件)

  • id:moon-fondu
    moon-fondu 2015/11/05 01:25:56
    Yoshiyaさんいつもありがとうございます！
    ですがすみません、「コンパイルエラー： Meキーワードの使用方法が不正です。」と出てきてしまって、うまく稼働させることが出来ませんでした・・・。

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

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

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

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ