[[20040722121935]]　『1マスに1文字づつ入力』（カオリ）　ページの最後に飛ぶ

『1マスに1文字づつ入力』（カオリ）

エクセルで作った原稿用紙のようなものに文章を入力したいのですが、1マスに1文字づつ入力のためとてつもなく手間と時間がかかり困っています。なにかよい方法はありますか？

 A1に取り合えずまとめて入力する例。
新規シートで試してください。
 A1に入力したものを横方向へ展開したい場合。
関数です。B1へ
=MID($A1,COLUMN(A1),1)
この数式を列方向（C1,D1・・・)へコピー、貼付。
関数の返り値として表示されるので、目的の位置へ
「形式を選択して貼付」「値」にチェックして貼付。
　
 A1に入力したものを縦方向へ展開したい場合。
A列を一文字分の幅に調節し、A1を選択、
メニュー「編集」＞「フィル」＞「文字の割り付け」
こちらは文字列が各セルに配分されます。
(KAMIYA)

早々のご回答ありがとうございました。
ところで、また問題が発生です。。
入力した文章のなかで、金額や日付があり、それを編集したりして使いまわすのですが、日付や金額でマスが余るとつめていったり、マスが足りないときはずらしていかなければなりません。
１マス削除や挿入で、自動的に文章もずれたりする方法はないですかねぇ。。。
ちなみにマスは縦２０マス横１３行で、Ａ4右面。真中に帯が入り、左も２０マス×１３行の作文用紙のようなものです。

 どちらかといえば、
ワードのようなワープロでの作業が向いている気がするのは
私だけでしょうか(笑）。たぶん表計算の部分もあるのでしょう。
ところで、縦書きなんですよね。
しかも右から左ですね。
私は特定の一つのセルへまとめて入力してそれを「原稿マス」へ
一字ずつ割り当てていく方針でやろうと思っていますが、
わからない問題があります。
　
・２０*１３*２以上になることがありますか？
・特定の部分だけの編集でほとんどが定型文でしょうか。
　定型文であり、公開して差し支えなければこの掲示板へ例示を希望します。
・途中で段落の変更はありますか？
　（文章が終わった後の空白、次の段落の字下げ）
・関数で無理（または処理が重くなる）場合にはマクロでの
　提案になるかもしれませんがそれでもよろしいでしょうか？
　
以上、返信お願いいたします。
(KAMIYA)

私自身もワードのほうがいいような？と思っていたのですが(>_<)、なんだかそーゆうやり方でやっていたらしくそのまま引き継いじゃったんですね(^^;)前の人は一文字づつ入力して、ずらすのも一文字づつ手作業でやってたみたいですが、私には我慢ならなかったので(笑)こちらに質問させていただいた次第です。
ところで、本題ですが、残念ながら法的に使用する文書なのでここに掲示はできないんです。。
わがまま申してすみません。
段落は5つあって１つの段落に日付、もうひとつの段落に日付と金額があります。あとの段落は編集無で、最後に日付と差出人や受取人を入力します。枚数は１枚でおさまる感じです。文章は定型文で日付と金額のみ編集です。そのあとの受取人等のところは手直しでも大丈夫なので、その本文のところが問題なんです。
多分、この説明では無理っぽいですよね．．。やり方は関数でもマクロでもいいのですが、
もしできなそうなときはあきらめます。。

 少し大物になってしまいましたが、マクロになれていない方でも
メンテナンスしやすいように作ったつもりです。
「 '////////メンテナンス部分//////////」で挟んだあたりが
ユーザー側で調整、変更出来る部分です。
現在の仕様としては
「入力用」という名前のシートのB1:B5の範囲へ文章入力
「印刷用」という名前のシートのA1以降の範囲へ出力
ということになっていますので、新規ブックでシート名を変更して
テストしてみてください。(KAMIYA)
　
 Sub 文章整形()
 Rem TEST_20040722
 Rem エクセルの学校[[20040722121935]]
 Dim InSh As Worksheet, PrSh As Worksheet
 Dim MyStr As String
 Dim MyCol As Long, COUNTER As Long, MyRow As Long, Req As Long
 Dim C As Range, MyRng As Range, PrRng As Range

 '////////メンテナンス部分//////////
 Rem 片側列数
 Const ColCount As Long = 13

 Rem 一列あたり字数
 Const RowCount As Long = 20

 Rem 中心の帯用列数
 Const SplitColCount As Long = 1

 Rem 入力用シート名とその範囲
 Set InSh = Worksheets("入力用")
 Set MyRng = InSh.Range("B1:B5")

 Rem 印刷用シート名と出力範囲の左端上辺セル
 Set PrSh = Worksheets("印刷用")
 Set PrRng = PrSh.Range("A1")
 '////////メンテナンス部分//////////

    With PrSh
        Rem 対象シートの書式設定・セル内容初期化
        .Cells.NumberFormatLocal = "G/標準"
        .Cells.ClearContents

        Rem 変数に初期値投入
        COUNTER = 1
        MyRow = PrRng.Row

        Rem 先頭行、右端の列から左端列へ20文字ごとの文字列作成。
        For MyCol = PrRng.Column - 1 + ColCount * 2 + SplitColCount To PrRng.Column Step -1

            Rem 帯用の列のみ処理回避
            If MyCol > PrRng.Column - 1 + ColCount + SplitColCount Or MyCol <= PrRng.Column - 1 + ColCount Then

                    Rem 新段落時、文章取得・行頭字下げのためのスペース挿入
                    If Len(MyStr) = 0 Then MyStr = "　" & MyRng.Cells(COUNTER).Value

                    Rem 行末禁則
                    Select Case Mid(MyStr, RowCount, 1)
                    Case Is = "「"
                        .Cells(MyRow, MyCol).Value = Left(MyStr, RowCount - 1)
                    Case Else
                        .Cells(MyRow, MyCol).Value = Left(MyStr, RowCount)
                    End Select

                    MyStr = Mid(MyStr, Len(.Cells(MyRow, MyCol)) + 1, Len(MyStr) - Len(.Cells(MyRow, MyCol)))

                    Select Case Left(MyStr, 1)
                    Rem 行頭禁則
                    Case Is = "」", "。", "、"
                        .Cells(MyRow, MyCol).Value = .Cells(MyRow, MyCol).Value & Left(MyStr, 1)
                        MyStr = Right(MyStr, Len(MyStr) - 1)
                    Rem 段落移行処理/終了処理
                    Case Is = ""
                        If COUNTER < MyRng.Count Then
                            COUNTER = COUNTER + 1
                        ElseIf COUNTER = MyRng.Count Then
                            Exit For
                        End If
                    Case Else
                    End Select

            End If

        Next MyCol

    End With

    Rem 各セルへの振分処理１（数式の投入）
    With PrRng.Offset(1, 0).Resize(RowCount, ColCount * 2 + SplitColCount)
        .FormulaR1C1 = "=MID(R" & MyRow & "C[0],ROW()-" & MyRow - 1 & ",1)"
    End With

    Rem 対象範囲の書式設定（文字列設定）
    With PrRng.Resize(RowCount + 1, ColCount * 2 + SplitColCount)
        .NumberFormatLocal = "@"
        .Orientation = xlVertical
        .Font.Name = "ＭＳ ゴシック"
    End With

    Rem 各セルへの振分処理２（値貼り付け）
    With PrRng.Offset(1, 0).Resize(RowCount, ColCount * 2 + SplitColCount)
        .Copy
        .PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False

    Rem 先頭行の処理
    For Each C In PrRng.Resize(1, ColCount * 2 + SplitColCount)
        C.Value = Left(C.Value, 1)
    Next C

    Rem 字数オーバー時の確認処理
    PrSh.Activate
    PrRng.Select
    If Len(MyStr) <> 0 Or COUNTER < MyRng.Count Then
        Req = MsgBox("所定の範囲に全部の文字列が収まりません。" & Chr(13) & _
               "結果を参考のため残す場合は「はい」を選択してください", vbYesNo)
        If Req = vbNo Then PrSh.Cells.ClearContents
    End If

 End Sub

 「印刷用」シートをすべてクリアする命令が含まれるので、
くれぐれも、原版で実行してデータを消してしまわないように注意してください。

 私も作ってみました。まだ改良の余地はあると思いますが・・

 まず分かり易いように ↓このマクロで枠を作ります。

 Sub 用紙枠作成()    
    Columns("A:AA").ColumnWidth = 3
    Columns("N").ColumnWidth = 0.5

    With Range("A1:AA20")
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
    End With

    With Range("N1:N20")
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
    End With    
 End Sub

 つぎに、

 １．ALT+F11キーで、VBEを起動
 ２．プロジェクトウィンドウのSheet1 を Ｗクリック
 ３．中央の真っ白なウィンドウ（コードウィンドウ）に以下のコードをコピペ

 Private Sub Worksheet_Change(ByVal Target As Range)
 Dim mystr As String
 Dim i As Long, r As Long, c As Long

    If Application.Intersect(Target, Range("A1:M20,O1:AA20")) Is Nothing Then Exit Sub
    If Target.Count <> 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub

 Application.EnableEvents = False

 '文字取得
    For c = 27 To 1 Step -1 '列ループ
        If c <> 14 Then '14列目は無視

            For r = 1 To 20 '行ループ
                If Cells(r, c).Value = "" Then '空白のとき
                    mystr = mystr & " " '仮にスペース
                Else
                    mystr = mystr & Cells(r, c).Value
                End If
            Next r

        End If
    Next c

 '文字展開
 i = 1
    For c = 27 To 1 Step -1 '列ループ
        If c <> 14 Then '14列目は無視

            For r = 1 To 20 '行ループ
                Cells(r, c).Value = Mid(mystr, i, 1)
                i = i + 1
            Next r

        End If

    Next c

 Application.EnableEvents = True
 End Sub

http://camaro.ddo.jp/Books/myWriting.xls

       (INA)

コメント返信：

[ 一覧(最新更新順) ]

[[20040722121935]] 『1マスに1文字づつ入力』（カオリ） ページの最後に飛ぶ

[[20040722121935]]　『1マスに1文字づつ入力』（カオリ）　ページの最後に飛ぶ