エクセル自動改行で互換性エラー

質問

エクセルで、１行35文字以上が記入されると自動で次のセルに改行される
仕様になるようにマクロを組んでいます。
ただ自身はマクロ未経験で、他のところから見様見真似で
コードを調整してくっつけただけで、知識はほとんどありません。
そのため、エクセルのバージョンが違うとうまく動作しないようになっています。
どこの記述がおかしいのか、足りないのかわかりません。

制作環境：excel 2010

以下内容です。
-------------------------------------------
' 改行自動
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim TgRng As Range
Dim N As Integer
Dim Ary()
Dim S As String
Set TgRng = Range("N10:N26")
Set Rng = Intersect(TgRng, Target)
If Rng Is Nothing Then Exit Sub
Application.EnableEvents = False
With Rng.Cells(1)
If Len(.Value) > 36 Then
S = .Value
For N = 0 To Int((Len(S) + 35) / 36)
ReDim Preserve Ary(N)
Ary(N) = Left(S, 36)
S = Mid(S, 37)
If S = "" Then Exit For
Next
.Resize(UBound(Ary) + 1).Value = Application.Transpose(Ary)
End If
End With
Application.EnableEvents = True
Set Rng = Nothing
Set TgRng = Nothing
Erase Ary
End Sub

' 切り取り禁止
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = 2 Then
Application.CutCopyMode = 0
End If
End Sub
-------------------------------------------

回答No.4

nishi6 · ベストアンサー

＞2003でも動くようにできることは可能なのでしょうか？？

以下のようにしてみました。あくまでも机上のコーディングです。2003もないため確認できていません。

'先頭に行カウンタ、変数rを定義
Dim r As Integer

'Resizeの行をコメントアウト
'.Resize(UBound(Ary) + 1).Value = Application.Transpose(Ary)

'以下の３行を挿入
For r = 0 To UBound(Ary)
　　.offset(r, 0) = Ary(r)
Next

＞半角文字は可
コードを見る限り、全角、半角文字が混ざると右がそろわないように思えます。

＞こちらは文字を入力した後、編集者が手動で「文字の割付」を行うということでよろしいでしょうか？

はい。編集者が行います。ただし、「文字の割付」ボタンがリボンの深い位置にあるので、ユーザー設定のリボンを作り、そのまん真ん中に「文字の割付」ボタンを配置しています。編集者は範囲を選択してクリックするだけです。

＞営業日報として・・・

これまでの対応として以下のようにしてきました。
１．この場合は、17×数行のセル範囲を結合して入力してもらう。
２．結合が許されないなら横書きのテキストボックスを挿入する。
３．きれいにしたいならWordオブジェクトを挿入する。
などで対応してきました。マクロで対応すると、まさに「車輪を作る、車軸を作る」ことになると判断したからです。まぁ判断なのでいろいろあってもいいんですが。

ご参考に。

お礼

諸々アドバイスありがとうございます。
マクロで対応する以外にも、あらゆる角度から
再度検討してみようと思います。

回答No.5

Sayakonomimoto

Sub ApplicationEVENT_Action()
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Application.Intersect(Target, Range("N10:N26")) Is Nothing Then '範囲に含まれて無くない＝含まれてたら！
If Target.Count > 1 Then 'いっぺんに複数行書こうとした場合
MsgBox "複数行はできません"
Exit Sub
End If

Dim TargetRangeData(20) As String

Dim MyRng As Range
Dim c As Range
Dim LenData As Long
Dim MojiData(50) As Variant
Dim AllMoji As String
Dim i As Long
LenData = 0
i = 0

Set MyRng = Range("N10:N26")
For Each c In MyRng
If Len(c.Value) <> "" Then
LenData = LenData + Len(c.Value)
MojiData(i) = c.Value
AllMoji = AllMoji + c.Value
i = i + 1
End If
Next

For i = 0 To UBound(MojiData)
If MojiData(i) > 35 And MojiData(i) <> "" Then
MojiData(i + 1) = MojiData(i + 1) & Mid(MojiData(i), 36, Len(MojiData(i)))
MojiData(i) = Left(MojiData(i), 35)
End If
Next

Application.EnableEvents = False
Range("N10:N26").Value = ""
Dim RowCount As Long
RowCount = 10
For i = 0 To UBound(MojiData)
If MojiData(i) <> "" Then
Range("N" & RowCount) = ""
Range("N" & RowCount) = MojiData(i)
RowCount = RowCount + 1
End If
Next
Application.EnableEvents = True
End If
Application.ScreenUpdating = True
End Sub

超適当ですが、作ってみました。（プログラムできる人からしたら、改善点が多々見つかるかと）
一番上のせるに勝手に持っていく？プログラムです。
35文字ずつ改行。
途中行を削除したり、文字数を減らした場合は
先頭行に戻り、35文字ずつで改行しなおします。

セルの内容を変更しても何も変わらなければ、
ApplicationEVENT_Actionを実行する。

お礼

ありがとうございます。
これも試させていただきます。

回答No.3

satoron666

合っているかどうかはさておき、
適当に考えてみました。

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True

If Not Application.Intersect(Target, Range("N10:N26")) Is Nothing Then '範囲に含まれて無くない＝含まれてたら！
If Target.Count > 1 Then
MsgBox "複数行はできません"
Exit Sub
End If

Dim TargetRangeData(20) As String
Application.EnableEvents = False

Dim i As Long
For i = 1 To 10
If Target.Offset(i - 1, 0).Value > 36 Then
Target.Offset(i, 0).Value = Target.Offset(i - 1, 0).Value
Target.Offset(i - 1, 0).Value = Left(Target.Offset(i - 1, 0).Value, 35)
Target.Offset(i, 0).Value = Replace(Target.Offset(i, 0).Value, Target.Offset(i - 1, 0).Value, "")
ElseIf Target.Offset(i - 1, 0).Value < 36 Then
Exit For
End If
Next
Application.EnableEvents = True
End If
End Sub

Application.EnableEventsをしっかりTrueに戻してあげないと
困ることになりそうなので…何か対策は考えておいたほうが良いかと思います。

お礼

サンプルありがとうございます。
一度試してみます。

回答No.2

nishi6

「エクセルのバージョンが違うと」と書かれていますが、解答側ではどのバージョンかわかりません。
コードを見る限り、「Transpose関数」はExcel2007以降の機能なので、Excel2003では動かないでしょう。

ここでまとめて貼り付けているのでFor Nextで１行ずつ貼り付けるんでしょうか。

＞１行35文字以上・・・
コードを見る限り36文字超ですね。

まだ作成途中と思いますが、コードを見て気が付いた点を書いてみます。

１．このマクロは上から下へ入力し、修正を許さないシカケでしょうか。

２．次の行に入力があって、前の行に入力し36文字を超えると余った文字列が次の行以降を書き換えてしまいます。

３．一旦36文字超の処理を行って2、3文字を次の行に送った後、上の行を30文字くらいに減らすとどうなりますか？2、3文字が次の行にそのままになっていませんか？

４．37文字目が句読点の場合、次の行に送りませんか。通常の日本語処理では禁則処理やぶら下げをします。

５．半角文字は入力禁止ですか？また、フォントサイズは変更不可ですか？

６．10～26行目に限定していますが、次の行に送ると、この限界を超えてしまいます。仕様ですか？

７．極端な例ですが、スペースキーをズッと押してEnterすると消しゴムの変りができます。

８．当然ですが、UnDoできません。

実はこれに近いことを考えたことがあるんですが、いろいろな要件を組み合わせると難しくなり中止しました。

で、対応としては、

　　「ホーム」タブ＞「編集」グループ＞フィル＞文字の割付

を利用することにしました。セルを広くすることなく、文字列を改行してくれて、上に書いた１～８をすべて満足してくれます。

ご参考に。

補足

> 「エクセルのバージョンが違うと」と書かれていますが、解答側ではどのバー
> ジョンかわかりません。
> コードを見る限り、「Transpose関数」はExcel2007以降の機能なので、
> Excel2003では動かないでしょう。

失礼しました。
まさにご指摘のとおりExcel2003で動きません。
2003でも動くようにできることは可能なのでしょうか？？

> まだ作成途中と思いますが、コードを見て気が付いた点を書いてみます。

1～4などおっしゃる通りの挙動をします。
半角文字は可。フォントサイズ変更は不可にしたいです。
また、業務日報としてA4印刷への対応を前提としておりますので、
入力スペースを限定する仕様にしました。

> 実はこれに近いことを考えたことがあるんですが、いろいろな要件を組み合わせ
> ると難しくなり中止しました。
> で、対応としては、
>
> 　「ホーム」タブ＞「編集」グループ＞フィル＞文字の割付

こちらは文字を入力した後、編集者が手動で「文字の割付」
を行うということでよろしいでしょうか？

回答No.1

kybo

バージョンによって、うまくいく、いかないというのは確認できませんでしたが、
おかしい部分としては、

If Len(.Value) > 36 Then
では、37文字以上になってしまいます。35文字づつセルに残すのであれば、
If Len(.Value) > 35 Then
ではないかと思います。

あと、
Ary(N) = Left(S, 36)
もおかしいです。

左から36文字取得なので、1行目は35文字取得し、2行目は36文字目から35文字取得となると思うので、
Ary(N) = Mid(S, N * 35 + 1, 35)
とした方がいいかもしれません。

'改行自動
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim TgRng As Range
Dim N As Integer
Dim Ary()
Dim S As String
Set TgRng = Range("N10:N26")
Set Rng = Intersect(TgRng, Target)
If Rng Is Nothing Then Exit Sub
Application.EnableEvents = False
With Rng.Cells(1)
If Len(.Value) > 35 Then '35行以内に改行？
S = .Value
For N = 0 To Len(S) \ 35
ReDim Preserve Ary(N)
Ary(N) = Mid(S, N * 35 + 1, 35)
Next
.Resize(UBound(Ary) + 1).Value = Application.Transpose(Ary)
End If
End With
Application.EnableEvents = True
Set Rng = Nothing
Set TgRng = Nothing
Erase Ary
End Sub

お礼

具体的にありがとうございます。
文字取得の箇所は参考にさせていただきます。