VBAについて教えて下さい

質問

EXCEL2010を使用中。

独学で、Web上で色々検索したものをパクリながら
VBAを組んでるようなレベルです。

今回教えて頂きたい内容ですが、
カード型の入力シート「Sheet名:入力」を作成して、
登録ボタンでデータベースシート「Sheet名:スケジュール」に
書き足していくような業務スケジュール表を作成中です。
わざわざそんな手のこんだものを
作らなくてもと思われるかもしれませんが
諸事情があっての事なので

登録ボタンのVBAは

Private Sub 登録_Click()
Dim row As Integer
row = WorksheetFunction.CountA(Sheets("スケジュール").Columns(1)) + 1

Sheets("スケジュール").Cells(row, 1).Value = Range("Q2").Value

Sheets("スケジュール").Cells(row, 2).Value = Range("G6:G7").Value
Sheets("スケジュール").Cells(row, 3).Value = Range("G8:G9").Value
Sheets("スケジュール").Cells(row, 4).Value = Range("G10:G11").Value
Sheets("スケジュール").Cells(row, 5).Value = Range("G12:G13").Value
Sheets("スケジュール").Cells(row, 6).Value = Range("G14:G15").Value
Sheets("スケジュール").Cells(row, 7).Value = Range("G16:G17").Value
Sheets("スケジュール").Cells(row, 8).Value = Range("G18:G19").Value
Sheets("スケジュール").Cells(row, 9).Value = Range("G20:G21").Value
Sheets("スケジュール").Cells(row, 10).Value = Range("G22:G23").Value
Sheets("スケジュール").Cells(row, 11).Value = Range("G24:G25").Value

Sheets("スケジュール").Cells(row, 12).Value = Range("M6:M7").Value
Sheets("スケジュール").Cells(row, 13).Value = Range("M8:M9").Value
Sheets("スケジュール").Cells(row, 14).Value = Range("M10:M11").Value
Sheets("スケジュール").Cells(row, 15).Value = Range("M12:M13").Value
Sheets("スケジュール").Cells(row, 16).Value = Range("M14:M15").Value
Sheets("スケジュール").Cells(row, 17).Value = Range("M16:M17").Value
Sheets("スケジュール").Cells(row, 18).Value = Range("M18:M19").Value
Sheets("スケジュール").Cells(row, 19).Value = Range("M20:M21").Value
Sheets("スケジュール").Cells(row, 20).Value = Range("M22:M23").Value
Sheets("スケジュール").Cells(row, 21).Value = Range("M24:M25").Value

Sheets("スケジュール").Cells(row, 22).Value = Range("S6:S7").Value
Sheets("スケジュール").Cells(row, 23).Value = Range("S8:S9").Value
Sheets("スケジュール").Cells(row, 24).Value = Range("S10:S11").Value
Sheets("スケジュール").Cells(row, 25).Value = Range("S12:S13").Value
Sheets("スケジュール").Cells(row, 26).Value = Range("S14:S15").Value
Sheets("スケジュール").Cells(row, 27).Value = Range("S16:S17").Value
Sheets("スケジュール").Cells(row, 28).Value = Range("S18:S19").Value
Sheets("スケジュール").Cells(row, 29).Value = Range("S20:S21").Value
Sheets("スケジュール").Cells(row, 30).Value = Range("S22:S23").Value
Sheets("スケジュール").Cells(row, 31).Value = Range("S24:S25").Value
Sheets("スケジュール").Cells(row, 32).Value = Range("S26:S27").Value

Range("Q1").Select

End Sub

としています。
この時、移行するセル内の文字数が指定文字数を超えると、
移行した先のセルの書式設定を「折り返して全体を表示する」に
設定変更をしたいですのですが、その方法について
ご教授いただけないでしょうか？
因みに現在の設定は、「縮小して全体を表示する」としています。

回答No.7

mar00 · ベストアンサー

Sub Macro1()
Dim row As Integer
Set WS01 = Worksheets("スケジュール")
row = WorksheetFunction.CountA(WS01.Columns(1)) + 1
myCol = 1
WS01.Cells(row, 1).Value = Range("Q2").Value
For i = 7 To 19 Step 6
For j = 6 To 26 Step 2
If IsEmpty(Cells(j, i)) Then
Exit For
Else
myCol = myCol + 1
With WS01.Cells(row, myCol)
moji = 3 '(1)
If Len(Cells(j, i)) > moji Then '(1)
.Value = Left(Cells(j, i), moji) & Chr(10) & Mid(Cells(j, i), moji + 1, Len(Cells(j, i)))
Else
.Value = Cells(j, i).Value
End If
End With
End If
Next j
Next i
Range("Q1").Select
End Sub
同じく(1)の行の3を希望の文字数に適宜修正して下さい。
折り返して表示ではなくて希望の文字数で改行するようにしてみました。

お礼

mar00さん、何度もすみません。
＃５の回答頂いた内容で、
自分なりに修正をしてみました。
合っているかがわかりませんが、
IF　LEN～を
IF　LENB～に
修正したらできました。
あとは、これを解読しながら
スキルアップを図りたいと思います。

今回、回答頂いた内容は
すごく勉強になりました。
何度もご回答頂き
本当にありがとうございました。

回答No.6

mar00

こちらで動作確認しましたが、折り返しになりました。
セルの幅が文字数より広くなっていませんか?

回答No.5

mar00

一部誤りがありました。
Private Sub 登録_Click()
Dim row As Integer
row = WorksheetFunction.CountA(Sheets("スケジュール").Columns(1)) + 1
myCol = 1
Sheets("スケジュール").Cells(row, 1).Value = Range("Q2").Value
For i = 7 To 19 Step 6
For j = 6 To 26 Step 2
If IsEmpty(Cells(j, i)) Then
Exit For
Else
myCol = myCol + 1
With Sheets("スケジュール").Cells(row, myCol)
.Value = Cells(j, i).Value
If Len(StrConv(Cells(j, i).Value, vbFromUnicode)) > 3 Then '(1)　ここを修正
.WrapText = True
End If
End With
End If
Next j
Next i
Range("Q1").Select
End Sub
(1)の3の部分は全角、半角を問わず3文字以上のときに折り返して表示に設定されます。
適宜修正してください。

補足

mar00さん、度々ありがとうございます。
上記の式に文字数を修正して試しましたが、
「折り返して表示」に、なりませんでした。
申し訳ありませんが、再度解決策を教えて頂けないでしょうか？
よろしくお願いいたします。

回答No.4

keithin

はて。
別にスケジュールの３１列分、最初からまとめて「折り返して全体を表示する」のチェックを入れておけば十分に見えますが。
まぁ敢えて言うなら、所定の文字数に達してなければ（セルをはみ出しても）折り返さないという事をしたいご相談だとすると。

dim r as long
dim h as range
r = worksheets("スケジュール").range("A65536").end(xlup).offset(1).row

with worksheets("スケジュール")
　.cells(r, 1).value = range("Q2").value
　.cells(r, 2).resize(10, 1).formula = "=INDEX(入力!$G$6:$G$25,ROW(A1)*2-1)"
　.cells(r, 12).resize(10, 1).formula = "=INDEX(入力!$M$6:$M$25,ROW(A1)*2-1)"
　.cells(r, 22).resize(11, 1).formula = "=INDEX(入力!$S$6:$S$27,ROW(A1)*2-1)"
　with .cells(r, 2).resize(31, 1)
　　.value = .value
　　for each h in .cells
　　　if lenb(strconv(h.value, vbfromunicode)) > 16 then　’所定の文字数
　　　　h.wraptext = true
　　　end if
　　next
　end with
end with

補足

keithinさん、ありがとうございます。
説明が不十分で申し訳ありません。
１～３１日までのそれぞれのセルの中で
指定文字数を超えたセルだけを折り返して
表示させたいです。
また、通常入る文字数は、3～５文字程度なのですが、
稀に文字数が８文字程度になる場合があるので、
その場合だけ、折り返して表示させたいです。
再度、教えていただけるとありがたいです。

回答No.3

watabe007

>Sheets("スケジュール").Cells(row, 2).Value = Range("G6:G7").Value

２行のデータ("G6:G7")を１行に転記するの？.

補足

watabe007さん、ありがとうございます。
都合により、2行のセルを結合しております。

回答No.2

mar00

動作には関係ないのですが
myRowの部分は列なのにmyRowではおかしですよね。
myCol等に自分でわかりやすいように修正してください。

補足

mar00さん、回答ありがとうございます。
VBAの内容について、まだ理解するまでには至っていませんが、
教えて頂いた内容で、試したところ、
スケジュールシートは、1日～31日まで横並び、
入力シートは縦3列となっていて、
入力シートの表示のままスケジュールシートに
移行されてしまいました。
実際は、横並びのフォームへと移行させたいです。
また、説明が不十分で申し訳ないのですが、
１～３１日のうち、それぞれのセルの中で、
指定文字数を超えたセルだけを折り返して
表示させたいです。
再度教えて頂けるとありがたいのですが・・・。

回答No.1

mar00

動作確認はしていませんので、ブックをコピーするなどしてから確認してみてください。
Private Sub 登録_Click()
Dim row As Integer
row = WorksheetFunction.CountA(Sheets("スケジュール").Columns(1)) + 1
Sheets("スケジュール").Cells(row, 1).Value = Range("Q2").Value
myRow = 1
For i = 7 To 19 Step 6
For j = 6 To 24 Step 2
myRow = myRow + 1
With Sheets("スケジュール").Cells(row, myRow)
.Value = Cells(j, i).Value
.WrapText = True　'折り返して全体を表示する
End With
Next j
Next i
Range("Q1").Select
End Sub

補足

ごめんなさい
mar00さんとkeithinさんの
VBAが混在してしまって、
補足を間違ってしまいました。
申し訳ありません。