Excel(かWord)で英文を一語ずつ縦に並べる

質問

いつもありがとうございます。
Microsoft　Excel（無理ならばWord）で英文を一語ずつ縦に並べ替えたいのですが、
どのようにすれば良いでしょうか。バージョンはともに2016です。

次のような英文があったとします。
I have now that will just make my work flow run smoothly

このように一語ずつ分けて書かれている英文を縦に
I
have
now
that
will
…後略

と並べ替えたいのですが、
マクロを使ったりして一括でなんとかできないでしょうか？

識者の方よろしくお願いいたします。

回答No.1

Chiquilin · ベストアンサー

Sub Macro1()
Dim wrdArry As Variant
Dim i As Long
With ActiveSheet
wrdArry = Split(.Range("A1").Value, " ")
For i = 1 To UBound(wrdArry)
.Cells(i, 1).Value = wrdArry(i)
Next i
End With
End Sub

でしょうか。

お礼

無事解決できました！本当に助かりました。ありがとうございますm(_ _)m

回答No.11

real beatin（@realbeatin）

No.10 です。訂正が１点あります。
★ vbCr を vbCrLf に置換すれば、
Excelでもなんでも)好きな場所に（Ctrl+Vとかで）貼付け
出来るようになる
という説明が抜けていました。
この際、
誤）
　vbCr
正）
　vbCrLf
という風に訂正させてください。
失礼しました。

回答No.10

real beatin（@realbeatin）

こんにちは。お邪魔します。

> 英文を一語ずつ
"単語"ではなく"一語"と表現されている点が結構気に掛かっていて、
試しに、幾つかの基準で難しい版を書いてたりもしてたのですが、、、。
例えば、word数で制限されている原稿とか書く？とかいう目的だったり？
とか、事情とか要求とかがもしあるならば、
具体的なオーダーの解る方がお応えし易かったかな、とか。
さておき。
単語の扱いにかけてはWord等のテキストエディターの得意分野、
ということはご承知の上のようですので、
Excel VBA として、
　一連のテキストとして出し入れする為のクリップボード
と、
　正規表現（英単語を取り出します。空白基準ではありません）
を使って、単語を抽出する簡易なマクロを
汎用性を意識して書いてみました。
ユーティティ的には悪くない設計と思いますけれど、
単語（一語）の扱いをどういう基準に落とすか、については、
そちらで内容をカスタマイズして貰うか、他の処理を追加して貰うとか、
必要になるのかも？と想像しています。

実際に処理する場面での手順としては、
１）単語を抽出したい元のセル範囲（複数可）を選択
２）マクロ[セル内の英単語取り出し]を実行
３）(Excelでもなんでも)好きな場所に（Ctrl+Vとかで）貼付け
のように、基本的にマニュアル操作感覚で
一般機能のように扱えるツールっぽく作ってあります。

VBA(VBE)の標準モジュールに下記のスクリプトをコピペすれば
すぐにも使用可能です。
マクロ[セル内の英単語取り出し]を
ボタンやShape等やショートカットキーに登録しておく方が
より便利になるかも、です。

' ' === 標準モジュール ==
' ' // 英単語をピックアップしたい元のセル範囲を事前に選択しておいてから実行
' ' // （単矩形範囲の単or飛び飛び複数セル または 単列or単行の飛び飛びセル範囲であれば機能する）
' ' // →ピックアップした英単語（改行区切り）をテキストとして、好きな場所に貼付け可能に
Sub セル内の英単語取り出し()
Dim sBuf As String
　　Selection.Copy
　　With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")　'　New DataObject
　　　　.GetFromClipboard
　　　　sBuf = 単語整形(.GetText)
　　　　.Clear
　　　　.SetText sBuf, 1
　　　　.PutInClipboard
　　End With
　　MsgBox "英単語データはクリップボードに格納され貼付け可能です"　'　煩いと思ったらこの行削除
End Sub

' ' // 英単語をピックアップしたい形に整形する関数（簡易版：非word数基準）
' ' // "I'm", "they've" などの省略形を 1 word として扱います。
Private Function 単語整形(ByVal sBuf As String) As String
　　If InStr(sBuf, """,") Then sBuf = Replace(sBuf, """", "")　'　DQ削除
　　With CreateObject("VBScript.RegExp")
　　　　.Global = True
　　　　.Pattern = "[^\w'\-]"
　　　　sBuf = .Replace(sBuf, " ")　'　「a-Z 0-9 _ ' -」以外の文字を削除
　　　　.Pattern = "\s+"
　　　　単語整形 = .Replace(LTrim$(sBuf), vbCr)　'　スペース(の塊り)を改行に置換
　　End With
End Function
' ' ===

回答No.9

tsubu-yuki

では・・ちょっとばかり皆さんと違う方向で(笑)。

Ａ１に例の英文があるとして・・
Ａ１セルにカーソルを合わせ、
・データタブから「区切り位置」
・「カンマやタブなどの・・・区切られたデータ」を選択し「次へ」
・「スペース」にチェック、「連続した・・」にもチェックし「次へ」
・「完了」
これで、単語ごとに区切られてセルに格納されますので、
・全範囲を選択し、コピー
・範囲外にフォーカスを置き（Ａ２セルとか）、
　ホームタブから「行列を入れ替えて貼り付け」
で完了。

ＶＢＡでやるなら
Sub Sample1()
　　Range("A1").TextToColumns DataType:=xlDelimited, _
　　　　　　　　　　　　　　　Destination:=Range("A1"), _
　　　　　　　　　　　　　　　ConsecutiveDelimiter:=True, _
　　　　　　　　　　　　　　　Comma:=False, _
　　　　　　　　　　　　　　　Space:=True
　　Range("A1:" & Cells(1, Columns.Count).End(xlToLeft).Address).Copy
　　Range("A2").PasteSpecial Transpose:=True
　　Application.CutCopyMode = False
End Sub
こんな感じですかね。

例えば英文中にカンマ「，」などが入るなら
（Yes, I do.　　とか）、
「区切り位置」機能では「カンマ」のチェックを。
ＶＢＡに書き加えるなら、
　　Comma:=True, _
に書き換えてみてくださいませ。

回答No.8

imogasi

この課題は、ワードＶＢＡ向きでしょう。
一般にワードＶＢＡは情報が得にくく、市販本もごく少なく、学習の関心も薄いようですが、関心を持って調べていると、ワードで単語が捉えられる便利な機能があったな、と記憶に残る。
http://www.relief.jp/docs/018025.html
Dim wrd As Word.Range
For Each wrd In ActiveDocument.Words
dic.Add wrd.Text, ""
Next wrd
のように、For Each 　　Nextで単語のコレクションを１つづつ捉えられる。
これをエクセルシートのＡ列なりに書き出せば仕舞です。
Ｗｏｒｄの文章に
ＶI have now that will just make my work flow run smoothly.
があるとして
上記のサイトはＤｉｃｔｉｏｎａｒｙという仕組みを使ったものだが、その部分を省いて、わかりやすくして、下記のプログラムを実行すると
Ｗｏｒｄの標準モジュールに張り付けて実行（Ｆ５キー）。
ーー
Sub 文書に含まれる単語をExcelに書き出す2()

Dim wrd As Word.Range
Dim key As Variant
Dim xls As Object 'Excel.Application
Dim i As Long
' -----
On Error Resume Next
Set xls = CreateObject("Excel.Application")
xls.Visible = True
With xls
.SheetsInNewWorkbook = 1
.Workbooks.Add
i = 1
For Each wrd In ActiveDocument.Words
.Cells(i, 1).Value = wrd.Text　　’Ｔｅｘｔが必要
i = i + 1
Next wrd
On Error GoTo 0
End With
Set xls = Nothing
End Sub
ーーー
結果
I
have
now
that
will
just
make
my
work
flow
run
smoothly
.
＝＝＝＝
しかし（英文）文章は多様なので、いろんなケースでチェックしてみる必要はあると思う。

回答No.7

Nouble

Chiquilin様、
いいものを
見せて、頂き
有難うございます

然し、其れ
配列ベクトルが
違う、だけ
ですよ

此れで、ループ無し
です

Sub test()
Dim 単語数 As Long, temp As Variant
　Let 単語数 = Len(Cells(1, 1)) - Len(Replace(Cells(, 1), " ", "")) + 2
　With ActiveSheet
　　Let temp = Application.Transpose(Split(.Cells(1, 1).Value, " "))
　　.Range(.Cells(2, 1), .Cells(単語数, 1)).Value = temp
　End With
End Sub

ワークシートでは
横方向が
配列、１次側、

縦方向が
配列、２次側、
です

１次配列の、各要素を
列内に、行違いで
連続で。並べたい
場合は
トランスポンド、すれば
ループ不要、です

回答No.6

msMike

Sheet2 において、
セル A1 に数値 1 を入力
式 =FIND(" ",Sheet1!A$1&" ",A1+1) を入力したセル A2 を下方にズズーッとオートフィル

Sheet1 において、
次式 を入力したセル A1 を下方にズズーッとオートフィル
=IFERROR(TRIM(MID(A$1&" ",Sheet2!A1,Sheet2!A2-Sheet2!A1)),"")

回答No.5

Nouble

済みません
少し
長く、なって
しまいました

エクセル、です（２００７以降対応）
A1に、原文が
入って、いる
と、して
=IFERROR(MID(" "&$A$1&" ",SMALL(INDEX((MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*10^30+ROW(INDIRECT("A1:A"&LEN($A$1)+2)),,),ROW(A1))+1,SMALL(INDEX((MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*100^100+ROW(INDIRECT("A1:A"&LEN($A$1)+2)),,),ROW(A2))-SMALL(INDEX((MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*10^30+ROW(INDIRECT("A1:A"&LEN($A$1)+2)),,),ROW(A1))),"")
下ヘ
フィル、頂ければ
使えます

但し、
＞空白は、半角で
　入れて、ください
＞単語は
　１文字、のみの
　空白で
　挟んで、ください
＞原文は
　100^100字、以内に
　して、ください
　（エクセルの　制約の、方が　きついはず　ですが）

MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)
で、
原文を、１文字ずつに
解体して、います

そして
空白で、ない
文字位置に
極大値を、与え
MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*10^30

加えて
全、文字位置値を
与え
MID(" "&$A$1&" ",SMALL(INDEX((MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*10^30+ROW(INDIRECT("A1:A"&LEN($A$1)+2))

定数配列的、扱いの
可能な、ものに
変え
INDEX((MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*10^30+ROW(INDIRECT("A1:A"&LEN($A$1)+2)),,)

先頭から、何文字目に
単語が、始るか
を、算出
SMALL(INDEX((MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*10^30+ROW(INDIRECT("A1:A"&LEN($A$1)+2)),,),ROW(A1))+1

先頭から、何文字目に
単語が、終るか
を、算出
SMALL(INDEX((MID(" "&$A$1&" ",ROW(INDIRECT("A1:A"&LEN($A$1)+2)),1)<>" ")*10^30+ROW(INDIRECT("A1:A"&LEN($A$1)+2)),,),ROW(A2))

させて、います

如何で、しょうか？

参考URL：

https://1drv.ms/x/s!AjviygfJDgV_1FrssKB8_9ih3lXX

回答No.4

Chiquilin

Excel2016なんだから 数式でやるなら

=IFERROR(INDEX(FILTERXML("<a><b>"&SUBSTITUTE($A$1," ","</b><b>")&"</b></a>","//b"),ROW(A1)),"")
下方向にコピー

でいいはずです。

回答No.3

bunjii

A1セルに提示の文字列があるとして次の操作をすれば目的通りになります。
A1セルを選択して「データ」タブの「区切り位置」を実行します。そのとき、区切り文字を空白にすると右側のセルへ1語ずつ分割されます。
次に1行目を選択してコピーコマンドでクリップボードへ記憶させます。
A2セルを選択して貼り付けを行いますが、行列を入れ替えて貼り付ければA2から下へ1語ずつ貼り付けられます。
1行目が不要になれば削除してください。

回答No.2

aokii

A1に英文がある場合
A2に以下の式を入れて下にドラッグコピーし、
=IF(ISERR(MID(A1,FIND(" ",A1)+1,1000)),"",MID(A1,FIND(" ",A1)+1,1000))
B1に以下の式を入れて下にドラッグコピーしてみてください。
=IF(ISERR(LEFT(A1,FIND(" ",A1)-1)),A1,LEFT(A1,FIND(" ",A1)-1))