こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

投稿日時 - 2012-08-14 16:56:40

QNo.7643545

困ってます

質問者が選んだベストアンサー

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を希望の文字数に適宜修正して下さい。
折り返して表示ではなくて希望の文字数で改行するようにしてみました。

投稿日時 - 2012-08-16 19:59:34

お礼

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

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

投稿日時 - 2012-08-17 16:25:37

ANo.7

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(7)

ANo.6

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

投稿日時 - 2012-08-16 18:55:52

ANo.5

一部誤りがありました。
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文字以上のときに折り返して表示に設定されます。
適宜修正してください。

投稿日時 - 2012-08-16 17:21:29

補足

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

投稿日時 - 2012-08-16 18:09:33

ANo.4

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

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

投稿日時 - 2012-08-14 20:51:50

補足

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

投稿日時 - 2012-08-16 10:23:53

ANo.3

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

2行のデータ("G6:G7")を1行に転記するの?.

投稿日時 - 2012-08-14 20:16:45

補足

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

投稿日時 - 2012-08-16 10:19:06

ANo.2

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

投稿日時 - 2012-08-14 20:01:55

補足

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

投稿日時 - 2012-08-16 10:16:51

ANo.1

動作確認はしていませんので、ブックをコピーするなどしてから確認してみてください。
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

投稿日時 - 2012-08-14 19:28:15

補足

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

投稿日時 - 2012-08-16 10:32:04

あなたにオススメの質問