回答編集履歴

ソース修正

2016/11/25 07:07

投稿

SASAHARA

スコア247

test CHANGED Viewed

@@ -446,9 +446,11 @@
-    'B列クリア
+    '修正：B列 →　B1セルクリア
-    Columns("B").Clear
+    'Columns("B").Clear
+    Range("B1").Clear

ソース追加

2016/11/25 07:07

投稿

SASAHARA

スコア247

test CHANGED Viewed

@@ -395,3 +395,287 @@
 以上、参考になれば幸いです。
+###　追記３
+回答および追記２のソースを一つのボタンで実行できるようにまとめてみました。
+（言われずともボタン１つで完了させるべきでした。横着してしまいすみません）
+```VBA
+' 改行する指定文字列の定義（増やしたい時は最後尾に「,追加文字列」とする）
+Private Const strSplit As String = "、,。,?,？,!,！,★,」,（笑）,・・・"
+'上記改行する文字列以外で使いそうもない記号・文字
+Private Const strReplace As String = "□"
+'ボタン押下処理
+Private Sub CommandButton1_Click()
+    Dim strA1 As String             ' A1の文字列を格納
+    Dim valNewLine As Variant       ' 改行指定文字列を格納
+    Dim valSplitA1 As Variant       ' A1の文字列を区切ったものを格納
+    Dim strMainSent As String       ' A1文字列を色々弄っては格納する文字列
+    Dim strTempSent As String       ' strLastSentに入れる前の仮
+    Dim strLastSent() As String     ' 最終的に出力するものを格納
+    Dim intNum As Integer           ' 繰り返した回数
+    Dim blnFlag As Boolean          ' フラグ（true:繰り返す、false：条件満たして終了）
+    Dim i As Integer                ' For文で使用
+    'B列クリア
+    Columns("B").Clear
+    'A1の長文を格納
+    If Cells(1, 1).Value = "" Then
+        MsgBox ("A1セルに文字がありません。")
+        Exit Sub
+    End If
+    strA1 = Cells(1, 1).Value
+    '改行する指定文字列
+    valNewLine = Split(strSplit, ",")
+    '指定文字列文繰り返す
+    strMainSent = strA1
+    For Each nl In valNewLine
+        strMainSent = Replace(strMainSent, nl, nl & strReplace)
+    Next nl
+    '---------------------------------------
+    ' ここまでで、指定文字列の後ろにすべて
+    ' 使いそうもない記号・文字が加わっている
+    '---------------------------------------
+    'A1の文字列を区切る
+    valSplitA1 = Split(strMainSent, strReplace)
+    '色々初期化
+    ReDim strLastSent(0)
+    blnFlag = True
+    intNum = 0
+    strTempSent = ""
+    'A1の文字列を整える
+    Do While blnFlag
+        If intNum <> 0 Then
+            '-----------------------------------------
+            ' 文字列の数が問題ないか確認(文字数)
+            ' 文字数ならLen、バイトで見るならLenBを使用
+            ' 今回は文字数で実施してます
+            '-----------------------------------------
+            '単体で32文字より大きかった時の処理
+            If Len(strTempSent) > 31 Then
+                ReDim Preserve strLastSent(UBound(strLastSent) + 1)
+                strLastSent(UBound(strLastSent)) = Left(strTempSent, 31)
+                strTempSent = Mid(strTempSent, 32)
+            End If
+            '組み合わせで32文字未満かどうかの処理
+            If Len(strTempSent + valSplitA1(intNum)) < 32 Then
+                strTempSent = strTempSent + valSplitA1(intNum)
+            Else
+                '格納配列を増やして最後尾に格納
+                ReDim Preserve strLastSent(UBound(strLastSent) + 1)
+                strLastSent(UBound(strLastSent)) = strTempSent
+                strTempSent = valSplitA1(intNum)
+            End If
+        Else
+            '初回のみ
+            strTempSent = valSplitA1(0)
+        End If
+        '最終配列か確認
+        If intNum = UBound(valSplitA1) Then
+            blnFlag = False
+            '最後の文字列を格納
+            ReDim Preserve strLastSent(UBound(strLastSent) + 1)
+            strLastSent(UBound(strLastSent)) = strTempSent
+        End If
+        intNum = intNum + 1
+    Loop
+    '出力処理①
+    For i = 1 To UBound(strLastSent)
+        Cells(1, 2).Value = Cells(1, 2).Value & strLastSent(i) & vbLf & vbLf
+    Next i
+    '---------------------------------------------------------
+    ' もし最終行「さぼらないように頑張りたいと思います。」の後に
+    ' 改行を入れたくなければ以下４行の先頭「'」を外して
+    ' 上記出力処理①のFor～Nextの３行の先頭に「'」をつけてください
+    '----------------------------------------------------------
+    '出力処理②
+'    For i = 1 To UBound(strLastSent) - 1
+'        Cells(1, 2).Value = Cells(1, 2).Value & strLastSent(i) & vbLf & vbLf
+'    Next i
+'    Cells(1, 2).Value = Cells(1, 2).Value & strLastSent(UBound(strLastSent))
+    '-- ここから追加 --
+    'B1セルにカーソルをあてる
+    Cells(1, 2).Select
+    'コード２
+    Dim buf As String, buf2 As String, CB As New DataObject
+    buf = ActiveCell
+    With CB
+        .SetText buf        ''変数のデータをDataObjectに格納する
+        .PutInClipboard     ''DataObjectのデータをクリップボードに格納する
+        .GetFromClipboard   ''クリップボードからDataObjectにデータを取得する
+        buf2 = .GetText     ''DataObjectのデータを変数に取得する
+    End With
+End Sub
+```
+変更箇所としては、B1セルにカーソルを移動させてからクリップボードにコピーをするようにしました。
+処理完了時点でクリップボードにコピーされておりますので、処理完了後に秀丸を開いて張り付ければご希望の処理になっているかと思います。ご確認くださいませ。
+ボタン操作の中にほぼソースを入れてしまったのでまったくもって綺麗とはかけ離れたソースになってしまいました・・・。お好みでプロシージャ分けなどして頂ければと思います。
+参考になれば幸いです。

文言修正

2016/11/24 11:15

投稿

SASAHARA

スコア247

test CHANGED Viewed

@@ -384,9 +384,11 @@
 という方法でご希望の方法が達成されるかと思います。
+（③実行しても特にアクションとかありませんが、④の貼り付けができます）
-ボタン２作るのが面倒な場合は、セルをコピーするのではなく、中を選択（B1でF2を選択）してからすべてコピペしたのちに秀丸に張り付ければこの現象は回避できます。
+ボタン２作るのが面倒な場合は、セルをコピーするのではなく、中を選択（B1セルでF2を選択）してからすべてコピペしたのちに秀丸に張り付ければこの現象は回避できます。

ソース追加

2016/11/24 09:44

投稿

SASAHARA

スコア247

test CHANGED Viewed

@@ -306,7 +306,7 @@
-###　追記
+###　追記１
@@ -321,3 +321,75 @@
 以上、参考になれば幸いです。
+###　追記２
+EXCELのB1セルをコピペして秀丸などに張り付けた時に先頭と最後尾に「"」が入ってしまう現象を確認いたしました。
+おそらく、こちらのサイトが参考になるかと思います[エクセル術](http://excel-magic.com/double-quotation/)
+こちらのサイトで色々手法が乗っておりますが、その中の「エクセルのコピー時にダイレクトにクリップボード操作するマクロ」が良いのではないかと思いました。
+上記の方法を現状に合わせるならば、今までのソースをボタン１とするならば、ボタン２を作って以下のソースをボタン２の処理とします。
+```VBA
+'ボタン２の処理
+Private Sub CommandButton2_Click()
+    Dim buf As String, buf2 As String, CB As New DataObject
+    buf = ActiveCell
+    With CB
+        .SetText buf        ''変数のデータをDataObjectに格納する
+        .PutInClipboard     ''DataObjectのデータをクリップボードに格納する
+        .GetFromClipboard   ''クリップボードからDataObjectにデータを取得する
+        buf2 = .GetText     ''DataObjectのデータを変数に取得する
+    End With
+End Sub
+```
+（ツールの参照設定にある　Microsoft Forms 2.0 Object Library　を使えるようにする必要あり。私の環境では最初から使えるようになっていたのでもしかしたら設定不要かもしれません）
+これを作成したのち、
+① ボタン１押下（これで「今日は、朝から天気が良く、～」の文章が改行してB1に作られる）
+② B1セルを選択
+③ ボタン２押下
+④ 秀丸などに張り付ける
+という方法でご希望の方法が達成されるかと思います。
+ボタン２作るのが面倒な場合は、セルをコピーするのではなく、中を選択（B1でF2を選択）してからすべてコピペしたのちに秀丸に張り付ければこの現象は回避できます。
+以上、参考になれば幸いです。

ソース一部修正

2016/11/24 05:45

投稿

SASAHARA

スコア247

test CHANGED Viewed

@@ -6,6 +6,10 @@
+※2016/11/24　修正
 ```VBA
 ' 改行する指定文字列の定義（増やしたい時は最後尾に「,追加文字列」とする）
@@ -192,22 +196,46 @@
         End If
         intNum = intNum + 1
     Loop
-    '出力処理
+    '出力処理① -- 以下、変更箇所
     For i = 1 To UBound(strLastSent)
-        Cells(i, 2) = strLastSent(i)
+        Cells(1, 2).Value = Cells(1, 2).Value & strLastSent(i) & vbLf & vbLf
     Next i
+    '---------------------------------------------------------
+    ' もし最終行「さぼらないように頑張りたいと思います。」の後に
+    ' 改行を入れたくなければ以下４行の先頭「'」を外して
+    ' 上記出力処理①のFor～Nextの３行の先頭に「'」をつけてください
+    '----------------------------------------------------------
+    '出力処理②
+'    For i = 1 To UBound(strLastSent) - 1
+'        Cells(1, 2).Value = Cells(1, 2).Value & strLastSent(i) & vbLf & vbLf
+'    Next i
+'    Cells(1, 2).Value = Cells(1, 2).Value & strLastSent(UBound(strLastSent))
 End Sub
@@ -226,22 +254,40 @@
 今日は、朝から天気が良く、真夏日になるらしいので、
 熱中症対策には十分気を付けたいです。（笑）
 庭にブールーベリーやひまわりが植えているので暑くなる前に水やり
 をしたいと思ます★
 ブルーベリーの実がなってきて色づいてきたのでもう少ししたら収穫
 できるのではないかと今から楽しみでなりません！？
 朝から水やりをした後に近所でラジオ体操をやっているので、
 姪っ子と甥っ子を連れて、ラジオ体操に今から行ってきます。
 「眠い」と思わず声にでてしまう時も多々ありますが、
 さぼらないように頑張りたいと思います。
@@ -255,3 +301,23 @@
 参考になれば幸いです。
+###　追記
+ご希望の処理にそっておらず申し訳ございません。
+出力処理箇所を修正いたしましたので、お試し頂ければと思います。
+出力箇所①、②は最終行の出力に合わせてどちらかを選んで頂ければと思います。
+以上、参考になれば幸いです。