- ベストアンサー
エクセル自動改行で互換性エラー
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オブジェクトを挿入する。 などで対応してきました。マクロで対応すると、まさに「車輪を作る、車軸を作る」ことになると判断したからです。まぁ判断なのでいろいろあってもいいんですが。 ご参考に。
関連するQ&A
- VBA 範囲選択時エラー
Private Sub Worksheet_SelectionChangeのVBAでA列B列C列でワンクリックで文字が入力できるように設定致しました。 その後、A列からC列を範囲選択してDeleteするとデバック 「実行時エラー 型が一致しません」と出てしまいます。業務上、そのセルのデータは一気に消したいので困っております。どなたか分かる方よろしくお願い致します。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range, rng_1 As Range, rng_2 As Range Application.EnableEvents = False Set rng_1 = Range("H17:H100") Set rng_2 = Range("I17:I100") Set rng_3 = Range("J17:J100") Set rng_4 = Range("K17:K100") Application.EnableEvents = True Set rng = Intersect(Target, rng_1) If Not rng Is Nothing Then Cancel = True If Target.Value = "" Then Target.Value = "(1)" Else Target.Value = "(1)" End If Else Set rng = Intersect(Target, rng_2) If Not rng Is Nothing Then Cancel = True If Target.Value = "(2)" Then Target.Value = Empty Else Target.Value = "(2)" End If Else Set rng = Intersect(Target, rng_3) If Not rng Is Nothing Then Cancel = True If Target.Value = "(3)" Then Target.Value = Empty Else Target.Value = "(3)" End If Else Set rng = Intersect(Target, rng_4) If Not rng Is Nothing Then Cancel = True If Target.Value = "(4)" Then Target.Value = Empty Else Target.Value = "(4)" End If End If End If End If End If End Sub
- 締切済み
- Visual Basic
- エクセル 数値結果の値によって日付を入れたい
シート2の2列目にOKが入ると、シート１のC列にOKが入り、更新された日がB列に表示されるようにしたいです。 C列に手入力でOKと入力すればB列に日付が表示されるのですが、C列をVLOOKで呼ぶようにしたら表示されなくなってしまいました。 どのように修正していいのか分かりません。 お教えいただければと思います。よろしくお願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Dim TgRng As Range Set TgRng = Intersect(Range("C1:C2000"), Target) If Not TgRng Is Nothing Then Application.EnableEvents = False For Each Rng In TgRng If Rng.Value = "OK" Then Rng.Offset(, -1).Value = Date End If Next Application.EnableEvents = True End If Set TgRng = Nothing End Sub
- ベストアンサー
- Excel（エクセル）
- VBA シートプログラムでRangeエラー
いつもお世話になっております。 Excel2003を使用しております。 シートに直接プログラムを書いています。 （例として、Sheet1とします） シートの内容が変わったときに、色々プログラムを実行していこうと思っているのですが、 Private Sub Worksheet_Change(ByVal Target As Range) のTargetが上手く取得できていない気がします。 今までは上手く動いていたのですが、 急にTargetの値に数値（セルに入力した値）が入ってしまうようになり 上手く組めなくて困っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim 開始1 As Range Dim 終了1 As Range Dim 開始2 As Range Dim 終了2 As Range Set 開始1 = Range("D5：D63") Set 終了1 = Range("E5：E63") Set 開始2 = Range("F5：F63") Set 終了2 = Range("G5：G63") If ThisWorkbook.ActiveSheet.ProtectContents Then '保護かかってたら End '強制終了 End If If Not Application.Intersect(Target, 開始1) Or Application.Intersect(Target, 実績日開始2) Is Nothing Then Call 開始(Target, 開始1, 開始2) ElseIf Not Application.Intersect(Target, 終了1) Or Application.Intersect(Target, 終了2) Is Nothing Then Msgbox "テスト！" End If End Sub '----------------------------------------------- Sub 開始(ByVal Target As Range, 開始1 As Range, 開始2 As Range) If Not Application.Intersect(Target, 開始1) Is Nothing Then MsgBox Target.Row End If If Not Application.Intersect(Target, 開始2) Is Nothing Then MsgBox Target.Row + 1 End If End Sub 全部シートに書いています。 まだ、テスト段階のため適当なプログラムしか書いておりません。 （指定範囲が変更された場合に、Msgboxを出したりなど 単純なことしかしていません） どこが悪いのか、教えて頂けないでしょうか？ よろしくお願い致します。
- ベストアンサー
- Excel（エクセル）
- ＶＢＡ 検索して一致したセルへジャンプさせたい
Excelにて、シート１のＡ列とシート２のＡ列のデータにＮｏを入れます。 シート１のＡ列のＮｏをクリックすると、シート２のＡ列の同じＮｏにジャンプするマクロを組みたいです。 現在組んでいるマクロは、 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Sht As Worksheet Dim Rng1 As Range Dim Rng2 As Range Dim FindCell As Range Set Sht = Worksheets("シート2") Set Rng1 = Range("A2:A100") Set Rng2 = Sht.Range("A2:A100")If Intersect(Target, Rng1) Is Nothing Then Exit Sub If Target.Count > 1 Then Exit Sub Set FindCell = Rng2.Find(Target.Value) If Not FindCell Is Nothing Then Application.Goto Reference:=FindCell, Scroll:=False End If End Sub です。 一応マクロは実行されますが、そうすると、シート１のＡ列の編集（Ｎｏを追加したり変更したり・・・）できません。 編集や変更もできて、検索マクロも実行できるというマクロの組み方はありますでしょうか？
- 締切済み
- その他（プログラミング・開発）
- EXCEL2003から2010への互換エラー
EXCEL2003で使っていたファイルを2010で開いたらコードが反応しなくなりました。 直す方法を教えてください。 具体的にはあるセルに入力すると別シートの「申請書」を印刷するというコードを入れています。 Private Sub worksheet_change(ByVal Target As Excel.Range) Dim h As Range Set h = Application.Intersect(Target, Range("AA15:AA45")) If h Is Nothing Then Exit Sub If h.Cells(1) = "" Then Exit Sub If MsgBox("申請書印刷しますか？", vbOKCancel) <> vbOK Then Exit Sub Worksheets("申請書").PrintOut End Sub よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- エクセル VBA の質問です。
A2～A20までのセルに文字を入力した段階で、それぞれB2～B20に入力日時を入れるVBAを以下のように組んでいます。 しかし、同様の条件を同一シートのE2～E20・F2～F20にも入力・自動表示できるようにしなければならなくなり、困っています。 どのように記述を変えればよいのか、教えていただけたらと思います。 宜しく御願いいたします。 Sub Worksheet_change(ByVal Target As Range) Dim Rng As Range Dim c As Range Set Rng = Range("A2:A20") If Intersect(Target,Rng) Is Nothing Then Exit Sub For Each c In Intersect(Target,Rng) If Not IsEmpty(c) Then c.Offset(, 1).Value = Now Else c.Offset(, 1).ClearContents End If Next Rng.Offset(, 1).EntireColumn.AutoFit End Sub 申し訳ありませんが、何卒、宜しく御願いいたします。
- ベストアンサー
- オフィス系ソフト
- VBAの記録を追加したい
エクセル2002使用です。 VBAで次のコードを使っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Set Target = Intersect(Range("C:C"), Target) If Target Is Nothing Then Exit Sub For Each Rng In Target If Rng.Value <> "" Then Rng.Offset(, -2).Value = Now Else ' (*) Rng.Offset(, -2).Value = "" ' (*) End If Next Rng End Sub （C列のセルに何か入力されると、A列の同じ行にその時刻が入る。） 同じシートで、F列に何か入力されるとE列の同じ行にその時刻が入るように書き直したいのですが、どうすればいいのでしょうか？ すいませんが、よろしくお願いします。
- ベストアンサー
- Visual Basic
- 複数セル参照で塗りつぶしを変更する
WIN:XP Off:2003 お願いします。 添付した図は入出金表です。 列Hに数値が入力されると列Eのセルが青く塗りつぶされます。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Dim aCell As Range Set Rng = Intersect(Target, Range("H:H")) If Rng Is Nothing Then Exit Sub For Each aCell In Rng If aCell.Value > 0 Then aCell.Offset(0, -3).Interior.ColorIndex = 17 Else aCell.Offset(0, -3).Interior.ColorIndex = xlNone End If Next aCell Set Rng = Nothing End Sub ここまでは出来たのですが、列Iに入力された時に列Eが赤に塗りつぶされるにはどうしたらいいでしょうか？ 同じ行のHとIに同時に数値が入る事はありません。 どうかお願い致します。
- ベストアンサー
- Visual Basic
- For～Next ループ内でUnionメソッドを使うとエラーになります。
下記の記述で2行おきのセル範囲から0以下のセルを除外したセル範囲を取得しようとすると Set Rng = Application.Union(r, Rng) の行でエラーが発生します。 'Set Rng = Range(Cells(12, 7), Cells(12, 7)) の行のコメントアウトをはずすと動きますが、 cells(12,7)の値が0以下だと本来の目的 である0以下のセル範囲を除外するという目的が果たせません。 Union(r,Rng)のRngがnothingになっているとエラーの原因になるのでしょうか？ Private Sub test() Dim r As Range Dim Rng As Range 'Set Rng = Range(Cells(12, 7), Cells(12, 7)) For i = 12 To 27 Step 3 If Cells(i, 7) > 0 Then Set r = Range(Cells(i, 7), Cells(i, 7)) Set Rng = Application.Union(r, Rng) End If Next i Rng.Select End Sub 以上教えてください。 お願いします。
- ベストアンサー
- Visual Basic
- 実行するとどうなるのでしょうか？
Private Sub CommandButton1_Click() Dim a, rng As Range, n As Long On Error GoTo Last Set rng = Application.InputBox("A1:I29", Type:=8) If Not rng Is Nothing Then Exit Sub On Error GoTo 0 a = rng.Value ReDim Preserve a(1 To rng.Rows.Count, 1 To rng.Columns.Count + 1) For i = 2 To UBound(a, 1) If IsEmpty(a(i, 2)) Then n = 0 Do While IsEmpty(a(i + n, 2)) a(i + n, UBound(a, 2)) = a(i - 1, 2) & ";" & n n = n + 1 Loop End If Next VSortMA a, 2, UBound(a, 1), UBound(a, 2) rng.Value = a Erase a Last: End Sub Private Sub VSortMA(ary, LB, UB, ref) Dim M As Variant, temp i As Long, ii As Long, iii As Long i = UB: ii = LB M = ary(Int((LB + UB) / 2), ref) Do While ii <= i Do While ary(ii, ref) < M ii = ii + 1 Loop Do While ary(i, ref) > M i = i - 1 Loop If ii <= i Then For iii = LBound(ary, 2) To UBound(ary, 2) temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp Next ii = ii + 1: i = i - 1 End If Loop If LB < i Then VSortMA ary, LB, i, ref If ii < UB Then VSortMA ary, ii, UB, ref End Sub
- 締切済み
- Visual Basic
お礼
諸々アドバイスありがとうございます。 マクロで対応する以外にも、あらゆる角度から 再度検討してみようと思います。