Ｐａｇｅ 834 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼行単位で文字を表示させたいのですが ポチ 03/2/27(木) 15:32 ┗Re:行単位で文字を表示させたいのですが Hirofumi 03/2/27(木) 21:41 ┣Re:行単位で文字を表示させたいのですが ポチ 03/2/27(木) 23:38 ┗Re:行単位で文字を表示させたいのですが ポチ 03/2/28(金) 13:18 ┗Re:行単位で文字を表示させたいのですが Hirofumi 03/2/28(金) 21:36 ┗Re:行単位で文字を表示させたいのですが ポチ 03/3/3(月) 9:56 ┗Re:行単位で文字を表示させたいのですが Hirofumi 03/3/3(月) 20:18 ┗Re:行単位で文字を表示させたいのですが ポチ 03/3/4(火) 10:14 ┗Re:行単位で文字を表示させたいのですが Hirofumi 03/3/4(火) 21:12 ┗Re:行単位で文字を表示させたいのですが ポチ 03/3/5(水) 8:58 ┗Re:行単位で文字を表示させたいのですが Hirofumi 03/3/5(水) 19:09 ┗Re:行単位で文字を表示させたいのですが ポチ 03/3/6(木) 8:47 ─────────────────────────────────────── ■題名 ： 行単位で文字を表示させたいのですが ■名前 ： ポチ ■日付 ： 03/2/27(木) 15:32 -------------------------------------------------------------------------
| 複数の事をVBAを使って行いたいのですが・・。 初級者なものでちんぷんかんぷんです。 どなたか教えていただければと思います。 管理表を作成しているのですが、この表で行いたい事は３つあります。 表はそれぞれ項目ごとにセルが分かれています。 １データを１行で管理しています。 よってデータの照合は１行内で完結されることになります。 行数は今後増えて行きます。 １.氏名を漢字で入力するとカナ氏名に半角のカタカナでフリガナされる。 （現時点では関数で対応していますがVBAで実行したい） ２.番号セルと返却番号セルの値が同じであれば、対応セルに「済」と 表示させたい。（初めに番号セルに入力しますので、返却番号セルに 入力された時に判断されるタイミングとなります。 そこで同じ値でなければブランクとなります。値＝数字） ３．２で対応セルに「済」と入力された行（行のデータ全て）だけを 同ファイル別シートに移行させる。 これは一旦目で見て確認してからにしたいので、コマンドボタンで 操作する形にしたいです。 番号 対応 カナ氏名 氏名 返却番号 101 ｱｱｱ あああ 102 222 済 ｲｲｲ いいい 222 ・・・・ ・・・・ それでは宜しくお願いします。 |
| UserFormで考えて見ました Noは昇順に並んでいることが条件です（既存の表にこのUserFormを適応する時は初回に番号でソートして置く） 探索の開始は、TextBox1のExitイベントで番号を探します TextBox1の無い番号を入れた場合、新規入力に成ります 例えば、10番、12番が存在する時、11番を指定すると10番、12番の間に行が挿入され11番が書きこまれます 尚、"済"レコードは"返却済み"と言うシートが必要ですので予め作成しておいて下さい また、キーの重複はキーが存在すればそこへ移動してしまうので特にメッセージを出していません UserFormの配置は、 TextBox1 番号 TextBox2 対応 TextBox3 フリガナ TextBox4 氏名 TextBox5 返却 CommandButton1 入力（UserFormからセルに書き込み） CommandButton2 削除（現在表示されている番号の行を削除） CommandButton3 ↑移動 CommandButton4 ↓移動 CommandButton5 "済"移動 を想定しています 以下のコードをUserFormモジュールに記入 Option Explicit Private lngListTop As Long Private lngListEnd As Long Private lngCurrent As Long Private lngFind As Long Private Const cstrSettle As String = "済" Private Const cstrMovement As String = "返却済み" Private Sub CommandButton1_Click() Dim i As Long If lngCurrent = -1 Then Exit Sub End If If lngFind <> -1 Then SetData lngCurrent Else If lngCurrent <= lngListEnd Then Cells(lngCurrent, 1).EntireRow.Insert End If SetData lngCurrent lngListEnd = lngListEnd + 1 End If ControlsInitialize With TextBox1 .Text = "" .SetFocus End With End Sub Private Sub CommandButton2_Click() Dim i As Long If lngFind <> -1 And lngCurrent <> -1 Then Beep If MsgBox("Key " & TextBox1.Text & " のDataを削除します", _ vbExclamation + vbOKCancel, "削除") = vbOK Then Rows(lngCurrent).Delete lngListEnd = lngListEnd - 1 ControlsInitialize TextBox1.Text = "" End If End If End Sub Private Sub CommandButton3_Click() lngCurrent = lngCurrent - 1 If lngCurrent < lngListTop Then lngCurrent = lngListTop End If lngFind = lngCurrent GetData lngCurrent CommandButton1.SetFocus End Sub Private Sub CommandButton4_Click() lngCurrent = lngCurrent + 1 If lngCurrent < lngListTop Or lngCurrent > lngListEnd Then lngCurrent = lngListEnd End If lngFind = lngCurrent GetData lngCurrent CommandButton1.SetFocus End Sub Private Sub CommandButton5_Click() Dim wksSettle As Worksheet Dim blnExist As Boolean Dim lngRow As Long For Each wksSettle In Worksheets If wksSettle.Name = cstrMovement Then blnExist = True Exit For End If Next wksSettle If blnExist Then If lngFind <> -1 And lngCurrent <> -1 Then Beep If MsgBox("Key " & TextBox1.Text & " のDataを移動します", _ vbExclamation + vbOKCancel, "削除") = vbOK Then With Worksheets(cstrMovement) lngRow = .Cells(65536, 1).End(xlUp).Row + 1 Range(Cells(lngCurrent, 1), _ Cells(lngCurrent, 5)).Copy _ Destination:=.Cells(lngRow, 1) End With Rows(lngCurrent).Delete lngListEnd = lngListEnd - 1 ControlsInitialize TextBox1.Text = "" End If End If Else Beep MsgBox cstrMovement & "のシートが有りません", _ vbExclamation + vbOKOnly, "NoSheet" End If End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim lngOver As Long Dim vntKey As Variant Dim rngIndex As Range With TextBox1 If .Text <> "" Then lngFind = -1 lngOver = lngListEnd + 1 If lngListTop <= lngListEnd Then Set rngIndex = Range(Cells(lngListTop, 1), _ Cells(lngListEnd, 1)) vntKey = CLng(.Text) lngFind = BinSearchCells(vntKey, rngIndex, , lngOver) Set rngIndex = Nothing End If If lngFind <> -1 Then lngCurrent = lngFind GetData lngCurrent Else ControlsInitialize Beep If MsgBox("該当するレコードが有りません作成します", _ vbExclamation + vbOKCancel, "新規入力") = vbOK Then lngCurrent = lngOver CommandButton1.Enabled = True Else TextBox1.Text = "" Cancel = True End If End If End If End With End Sub Private Sub TextBox4_AfterUpdate() If TextBox3.Text = "" And TextBox4.Text <> "" Then TextBox3.Text = Application.GetPhonetic(CStr(TextBox4.Text)) End If End Sub Private Sub TextBox5_AfterUpdate() If TextBox1.Text = TextBox5.Text Then TextBox2.Text = cstrSettle End If End Sub Private Sub UserForm_Initialize() lngListTop = 2 lngListEnd = Cells(65536, 1).End(xlUp).Row If lngListTop > lngListEnd Then lngListEnd = lngListTop - 1 Else If Cells(lngListEnd, 1).Value = "" Then lngListEnd = lngListEnd - 1 End If End If ControlsInitialize TextBox1.Text = "" TextBox2.Enabled = False End Sub Private Sub ControlsInitialize() Dim i As Long For i = 2 To 5 Me.Controls("TextBox" & i).Text = "" Next i CommandButton1.Enabled = False CommandButton2.Enabled = False CommandButton5.Enabled = False lngCurrent = -1 lngFind = -1 End Sub Private Sub GetData(lngRow As Long) Dim i As Long With Cells(lngRow, 1) .Activate For i = 1 To 5 Me.Controls("TextBox" & i).Text _ = .Offset(0, i - 1).Value Next i End With CommandButton1.Enabled = True CommandButton2.Enabled = True If TextBox2.Text = cstrSettle Then CommandButton5.Enabled = True End If End Sub Private Sub SetData(lngRow As Long) Dim i As Long With Cells(lngRow, 1) .Activate For i = 1 To 5 .Offset(0, i - 1).Value _ = Me.Controls("TextBox" & i).Text Next i End With End Sub 以下を標準モジュールに記述 Option Explicit Option Compare Text Public Function BinSearchCells(vntKey As Variant, _ rngScope As Range, _ Optional lngUnder As Long = -1, _ Optional lngOver As Long = -1) As Long ' 二進探索セル版 Dim lngLow As Long Dim lngHigh As Long Dim lngMiddle As Long Dim vntTmp As Variant Dim lngStartAdd As Long With rngScope lngStartAdd = .Row - 1 lngLow = 1 lngHigh = .Rows.Count Do While lngLow <= lngHigh lngMiddle = (lngLow + lngHigh) \ 2 vntTmp = .Cells(lngMiddle).Value Select Case vntKey Case Is > vntTmp lngLow = lngMiddle + 1 Case Is < vntTmp lngHigh = lngMiddle - 1 Case Is = vntTmp lngLow = lngMiddle + 1 lngHigh = lngMiddle - 1 End Select Loop End With If lngLow = lngHigh + 2 Then BinSearchCells = lngStartAdd + lngMiddle Else BinSearchCells = -1 End If lngUnder = lngStartAdd + lngHigh lngOver = lngStartAdd + lngLow End Function |
| Hirofumi さん！どうもありがとうございます。 なんだかとっても面倒な事をお願いしているという事がよくわかりました。 すみませんです。。 今ちょっとやってみているところですが、UserFormを使用するだけでも 本格的という感じです。 こんな上級っぽいものを作っていただき恐縮しています。 果たして私に理解できるのかどうか・・・。 取り急ぎお礼だけでもと思っての返信です。 これから早速とりかかります。 では、結果は明日ご報告します！ ありがとうございました。 |
| Hirofumi さん かなり難航しています・・・。 ３つの条件のうち一つだけでも何とかできればと思っています。 行で同じ番号が２つ発生すると「返却」とセルに表示できれば良いのですが・・・。 １列目の番号に対して１１列目に入力した番号が同じであれば２列目のセルに 返却と出したいのですが・・・。１行単位でデータを見て判断します。 ＩＦ文で考え中なのですが的外れでしょうか？ |
| コメントを書かなくてゴメンナサイ >3 つの条件のうち一つだけでも何とかできればと思っています｡ >１.氏名を漢字で入力するとカナ氏名に半角のカタカナでフリガナされる。 これに就いて、やった事が無いので上手くいってるのか同かの問題いは有りますが 一応、以下の部分で行っています Private Sub TextBox4_AfterUpdate() If TextBox3.Text = "" And TextBox4.Text <> "" Then TextBox3.Text = Application.GetPhonetic(CStr(TextBox4.Text)) End If End Sub 意味は TextBox4が更新された場合 もし、TextBox3が""で（フリガナのTextBoxに何も入力されていない場合）で かつ、TextBox4（氏名のTextBox）に入力が有った場合、 TextBox3にフリガナを入れる >２.番号セルと返却番号セルの値が同じであれば、対応セルに「済」と表示させたい。 これに就いては、以下の部分で行っていますが、当方のミスで違う番号の場合「済」を 消す処理を行っていませんでした Private Sub TextBox5_AfterUpdate() If TextBox1.Text = TextBox5.Text Then TextBox2.Text = cstrSettle End If End Sub これを以下に修正して下さい Private Sub TextBox5_AfterUpdate() If TextBox1.Text = TextBox5.Text Then TextBox2.Text = cstrSettle Else TextBox2.Text = "" End If End Sub 意味は、 TextBox5が更新された場合 もし、TextBox1.TextとTextBox5.Textが同じなら TextBox2.TextにcstrSettle（文字定数として定義した「済」）を代入 違うなら、TextBox2.Textに""を代入 >３．２で対応セルに「済」と入力された行（行のデータ全て）だけを > 同ファイル別シートに移行させる｡ これに就いては、以下で行っています Private Sub CommandButton5_Click() Dim wksSettle As Worksheet Dim blnExist As Boolean Dim lngRow As Long '移動するシートの有無を確認 'Worksheetsコレクションに有るシートを比較 For Each wksSettle In Worksheets 'もし、シートにcstrMovementで定義し名前と同じ物があれば If wksSettle.Name = cstrMovement Then 'フラグをTrueにしてForを脱出 blnExist = True Exit For End If Next wksSettle 'もし、シートが有れば If blnExist Then 'もし、現在UserFormに表示されている行が新規入力行で無いなら 'lngFind <> -1はListに存在する行で、 'lngCurrent <> -1は現在UserFormに表示されている行を意味します If lngFind <> -1 And lngCurrent <> -1 Then '警告音 Beep 'もし、メセージボックスのOkボタンが押されたなら If MsgBox("Key " & TextBox1.Text & " のDataを移動します", _ vbExclamation + vbOKCancel, "削除") = vbOK Then '移動先シートについて With Worksheets(cstrMovement) '最終行を取得 lngRow = .Cells(65536, 1).End(xlUp).Row + 1 '移動する行をコピーして移動先の最終行の１つ下にペースト Range(Cells(lngCurrent, 1), _ Cells(lngCurrent, 5)).Copy _ Destination:=.Cells(lngRow, 1) End With '移動行を削除 Rows(lngCurrent).Delete 'Listの最終位置ポインタを更新 lngListEnd = lngListEnd - 1 'UserFoprmをクリア ControlsInitialize TextBox1.Text = "" End If End If Else Beep MsgBox cstrMovement & "のシートが有りません", _ vbExclamation + vbOKOnly, "NoSheet" End If End Sub 尚、このUserFormのTextBoxの番号は列に対応させて有ります もし、表示する列を増やしたい場合、必要なTextBoxを増設し 以下のプロシージャを変更すれば出来ると思います Sub ControlsInitialize() UserFormのTextBoxをクリアして、コマンドボタンの表示を設定 Sub GetData(lngRow As Long) シートのセルからUserFormのTextBoxにデータを読み込む SetData(lngRow As Long) UserFormのTextBoxからシートのセルにデータを書き込む この中の For i = 1 To 5 で5がTextBoxの数ですので これを増設したTextBoxの数（ナンバー）にすれば善いと思います |
| Hirofumi さん ご丁寧な説明まで付け加えていただいてありがとうございます！ ですが、ですが・・ 早速やってみたのですがやはり上手くできません。 トホホです。 以下のメッセージが出ました。 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ Private Sub UserForm_Click() Option Explict 部分では「コンパイルエラー プロシージャ内では無効です」 Private Sub TextBox1_Exit の GetData lngCurrent 部分では 「コンパイルエラーBy Ref引数の形が一致しません」 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ やはり未熟な私には難しいです。 それでも"返却"文字が表示されるようにだけでもしたいので もし宜しければお教えいただけませんか？ UserFormを使用せずそのままセルに数字を入力し、 それぞれのセルに入力した２つの数字が同じであれば ３つめのセルに返却と表示されるようにしたいのですが・・・。 1行1データですので行単位での実行となります。 本当に何度もすみません。 宜しくお願い致します。 環境はWin98 EXEL2000 でやっています。 |
| >以下のメッセージが出ました。 >＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ > >Private Sub UserForm_Click() >Option Explict >部分では「コンパイルエラー プロシージャ内では無効です」 > > >Private Sub TextBox1_Exit の >GetData lngCurrent >部分では >「コンパイルエラーBy Ref引数の形が一致しません」 > >＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ 私のコードを記述する位置をま違ったと思います UserFormにコードを記述為、コードの表示をクリックするとExselのバグか？ Private Sub UserForm_Click() End Sub のイベントプロシージャが作成されます 多分、この Private Sub 〜 End Sub の間に張りつけたと思われます コードの表示の中身を全て削除して張りつけて見て下さい 多分、それで大丈夫だと思います また、 >それでも"返却"文字が表示されるようにだけでもしたいので >もし宜しければお教えいただけませんか？ >UserFormを使用せずそのままセルに数字を入力し、 >それぞれのセルに入力した２つの数字が同じであれば >３つめのセルに返却と表示されるようにしたいのですが・・・。 あれ？、三つ目のセル？、二つ目のセルじゃなかったでしたっけ 余り上手くないので気が進みませんが以下のように記述すれば言いと思います 記述場所は、Listが有るシートモジュールです K列にA列と同じ物が入力されれば、B列に「返却」が入力されますし、 違う物が入れば""が入力されます Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim lngRow As Long If Target.Column = 11 Then lngRow = Target.Row If Cells(lngRow, 1) <> "" _ And Cells(lngRow, 1) = Cells(lngRow, 11) Then Cells(lngRow, 3) = "返却" Else Cells(lngRow, 3) = "" End If End If End Sub |
| Hirofumi さん 早速お教えくださった以下実行をしてみたのですが、またまた問題が一つ 浮上してしまいました。 私は他にも１件質問を挙げているのですが（No.４０５２です）、そこで お教えいただいた同格の名前を用いたものを使っている為、コンパイルエラー となってしまいます。 “「Private Sub Worksheet_Change(ByVal Target As Excel.Range)” の部分です。 No.４０５２での内容はA列内で入力した数字がダブってしまうとメッセージが 出るようにしました。 この場合適用範囲からいうと、A列のみに対する処理と、今回Hirofumiさんに 質問させてもらっている行単位で行なう処理とで切り分けなければいけない のですよね？ その部分がわかりません。 また、Hirofumiさんの仰る通りA列とK列の数字が合致した場合B列に返却と 表示したいので、今回お教え下さった内容で間違いありません。 （自分で質問した内容までも間違えてしまい、なんとも情けないです） もし宜しければヒントだけでもお教えいただければと思います。 何度も何度も何度もすみません。 |
| 両方を一緒にして少しかきかえました 4052の方がOffsetで書いているので、それに揃えました 多分、これで動くと思います Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim vntValue As Variant With Target If .Count <> 1 Or .Row < 2 Then Exit Sub End If Select Case .Column Case 11 If .Offset(, -10).Value <> "" _ And .Offset(, -10).Value = .Value Then vntValue = "返却" Else vntValue = "" End If .Offset(, -8).Value = vntValue Case 1 If .Value <> "" Then vntValue = Application.Match(.Value, _ Range("A1", .Offset(-1)).Value, 0) If Not IsError(vntValue) Then Beep MsgBox .Value & "番はすでにあります。" .Value = "" .Select End If End If End Select End With End Sub |
| Hirofumi さん やっとできました！ありがとうございます。。 返却という文字がC列に表示されたのですが、 -8を-9に変更したらB列に表示されるようになりました。 本当に助かりました！ありがとうございます。 これでずいぶんと仕事の効率化がはかれるはずです。 それでは、風邪などひかぬようお体にお気をつけてください！！ |
| UserFormの方も暇が有ったら試して見てね 私としては、レコードの移動、削除、修正等は、UserFormの方が 上手く行くような気がします |
| Hirofumi さん はい、UserFormの方も試してみますね！ 自分のための勉強にもなると思います。 >UserFormの方も暇が有ったら試して見てね >私としては、レコードの移動、削除、修正等は、UserFormの方が >上手く行くような気がします |