Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9972 / 13646 ツリー ←次へ | 前へ→

【24405】登録方法 まこと 05/4/21(木) 17:32 質問[未読]
【24407】Re:登録方法 ni 05/4/21(木) 17:49 発言[未読]
【24421】Re:登録方法 YN61 05/4/21(木) 21:34 回答[未読]
【24491】Re:登録方法 Hirofumi 05/4/23(土) 7:16 回答[未読]
【24496】Re:登録方法 まこと 05/4/23(土) 10:26 質問[未読]
【24497】Re:登録方法 Hirofumi 05/4/23(土) 11:41 回答[未読]
【24498】Re:登録方法 Hirofumi 05/4/23(土) 11:48 回答[未読]
【24506】Re:登録方法 まこと 05/4/23(土) 17:39 質問[未読]
【24508】Re:登録方法 Hirofumi 05/4/23(土) 19:04 回答[未読]
【24509】Re:登録方法 Hirofumi 05/4/23(土) 19:14 発言[未読]
【24511】Re:登録方法 まこと 05/4/23(土) 20:36 お礼[未読]
【24510】Re:登録方法 YN61 05/4/23(土) 20:03 発言[未読]
【24514】Re:登録方法 サラリーマン 05/4/23(土) 22:27 発言[未読]
【24515】Re:登録方法 サラリーマン 05/4/23(土) 22:29 質問[未読]
【24517】Re:登録方法 Hirofumi 05/4/23(土) 23:15 回答[未読]
【24523】サラリーマンさんの質問について Hirofumi 05/4/24(日) 7:05 発言[未読]
【24524】Re:サラリーマンさんの質問について サラリーマン 05/4/24(日) 8:02 発言[未読]

【24405】登録方法
質問  まこと  - 05/4/21(木) 17:32 -

引用なし
パスワード
   名簿管理を作っているのですが、いきずまってしまい
ご教示ください。
フォームより登録ができるようにしているのですが例の通りに挿入?できるように
したいのですが、宜しくお願いします。

(例)
A05のIDをもつ人の新規登録があった場合
A04とB01の間に登録できますでしょうか?

sheet1
  A     B    C    D    E   F   G
1 ID   氏名  生年月日  年齢  **   *   *
2 A01
3 A02
4 A03
5 A04
6 B01
7 B02
8 B03

【24407】Re:登録方法
発言  ni  - 05/4/21(木) 17:49 -

引用なし
パスワード
   こんにちは

最後の行に登録してから、IDでソートしてはいかがですか。

【24421】Re:登録方法
回答  YN61  - 05/4/21(木) 21:34 -

引用なし
パスワード
   ▼まこと さん:

>フォームより登録ができるようにしているのですが例の通りに挿入?できるように
>したいのですが、宜しくお願いします。
→→これは、昇順で並べ替えが簡単に出来ますが…

入力フォームを
作成してみました、一度ご検討ください。
A列のID、B列の氏名、C列の生年月日までしました…後は同じ要領です。

フォームのUserForm1に貼り付け
「入力」にする…EnterKeyでも操作可です。

Private Sub CommandButton1_Click()
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Value = TextBox1.Value  'ID
ActiveCell.Offset(, 1).Value = TextBox2.Value '氏名
ActiveCell.Offset(, 2).Value = TextBox3.Value '生年月日

TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox3.SetFocus
TextBox2.SetFocus
TextBox1.SetFocus

Range("A65536").End(xlUp).Offset(1, 0).Select
End Sub

フォームのUserForm1に貼り付け
「閉じる」にする
Private Sub CommandButton2_Click()
Unload UserForm
End Sub


標準モジュールに貼り付ける
「フォーム」を出す

Sub Uform1show()
UserForm1.Show
End Sub


>(例)
>A05のIDをもつ人の新規登録があった場合
>A04とB01の間に登録できますでしょうか?
>
>sheet1
>  A     B    C    D    E   F   G
>1 ID   氏名  生年月日  年齢  **   *   *
>2 A01
>3 A02
>4 A03
>5 A04
>6 B01
>7 B02
>8 B03

【24491】Re:登録方法
回答  Hirofumi  - 05/4/23(土) 7:16 -

引用なし
パスワード
   フォームというのがUserFormならこんな形かな?
UserFormには、TextBoxが7個、CommandButtonが2個有る物とします
CommandButton1は、データの追加、更新とします
CommandButton2は、データの削除とします
TextBox1は、IDの入力とします
IDが入力された場合、ID列(A列)を探索し
IDが該当する場合、TextBoxにListからデータを読み込み、更新モードと成ります
IDの該当が無い場合、追加モードと成り、
「追加、更新」ボタンで挿入位置に行が挿入されデータが書きこまれます
「削除」ボタンは、TextBoxに現在表示されている行を削除します
尚、ID列は、数値と文字列を混在させると上手く動きません、
必ずどちらかに揃えて下さい(現在のコードでは、追加したIDは、文字列と成ります)

Option Explicit

'Listの列数
Const lngCoiumns As Long = 7

'Listの先頭セル位置
Private rngList As Range
'IDのセル範囲
Private rngSearch As Range
'Listの行数
Private lngRows As Long
'Listの現在行(Offset値)
Private lngCurrent As Long

Private Sub CommandButton1_Click()

'  行の追加、更新

  Dim lngFound As Long
  Dim lngOver As Long
  
  If TextBox1.Text = "" Then
    Exit Sub
  End If
  
  '現在行が未定なら
  If lngCurrent = 0 Then
    'IDのセル範囲からTextBox1値の行挿入位置を探索
    lngFound = RowSearch(TextBox1.Text, rngSearch, lngOver)
    '行挿入位置がList範囲内なら
    If lngOver <= lngRows Then
      '行を挿入
      rngList.Offset(lngOver).EntireRow.Insert
    End If
    '現在行を挿入位置に設定
    lngCurrent = lngOver
    'List行数をインクリメント
    lngRows = lngRows + 1
    'IDのセル範囲を更新
    Set rngSearch = rngList.Offset(1).Resize(lngRows)
  End If
  
  'TextBoxの値を現在行に出力
  PutCellsData lngCurrent
  
End Sub

Private Sub CommandButton2_Click()

'  行の削除

  '現在行が未定なら
  If lngCurrent = 0 Then
    Exit Sub
  Else
    If MsgBox(TextBox1.Text & "のデータが削除されます", _
        vbExclamation + vbOKCancel, "行削除") = vbOK Then
      '行を削除
      rngList.Offset(lngCurrent).EntireRow.Delete
    End If
    'List行数をディリメント
    lngRows = lngRows - 1
    'IDのセル範囲を更新
    Set rngSearch = rngList.Offset(1).Resize(lngRows)
  End If
    
  'TextBoxのデータをクリア
  TextBox1.Text = ""
  DataClear
    
End Sub

Private Sub TextBox1_AfterUpdate()

  With TextBox1
    If .Text <> "" Then
      'TextBoxの値を半角大文字に揃える
      .Text = StrConv(.Text, vbNarrow + vbUpperCase)
      'IDのセル範囲からTextBox1値を探索、現在行を探索位置に
      lngCurrent = RowSearch(.Text, rngSearch)
      'もし、IDが有った場合
      If lngCurrent > 0 Then
        'TextBoxにListの値を読み込み
        GetCellsData lngCurrent
      Else
        'TextBoxをクリア
        DataClear
      End If
    Else
      '現在行を未定に設定
      lngCurrent = 0
    End If
  End With
  
End Sub

Private Sub UserForm_Initialize()

  'Listの先頭位置を設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  With rngList
    'Listの行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'IDのセル範囲を取得
    If lngRows > 0 Then
      Set rngSearch = .Offset(1).Resize(lngRows)
    End If
  End With
  '現在行を0に設定
  lngCurrent = 0
  
End Sub

Private Sub UserForm_Terminate()

  Set rngList = Nothing
  Set rngSearch = Nothing
  
End Sub

Private Sub GetCellsData(lngRow As Long)

'  TextBoxにデータの読み込み

  Dim i As Long
  
  With rngList
    For i = 2 To lngCoiumns
      Controls("TextBox" & i).Text = .Offset(lngRow, i - 1)
    Next i
  End With
    
End Sub

Private Sub PutCellsData(lngRow As Long)

'  Listにデータの出力

  Dim i As Long
  
  With rngList
    'IDを文字列として扱う時は、この行が必要
    .Offset(lngRow).NumberFormatLocal = "@"
    For i = 1 To lngCoiumns
      .Offset(lngRow, i - 1) = Controls("TextBox" & i).Text
    Next i
  End With
  
  TextBox1.Text = ""
  DataClear
  
End Sub

Private Sub DataClear()

'  TextBoxのデータクリア

  Dim i As Long
  
  For i = 2 To lngCoiumns
    Controls("TextBox" & i).Text = ""
  Next i
  
  lngCurrent = 0
  TextBox1.SetFocus
    
End Sub

Private Function RowSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long) As Long

  Dim vntFind As Variant
  
  If rngScope Is Nothing Then
    lngOver = 1
    Exit Function
  End If
  
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      RowSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  Else
    lngOver = 1
  End If
  
End Function

【24496】Re:登録方法
質問  まこと  - 05/4/23(土) 10:26 -

引用なし
パスワード
   ▼Hirofumi さん.YN61さん.
おはようございます。
大変勉強になります。

Hirofumi さんに質問なのですが、

事前に入力してあるIDを数値から文字列に揃えましたが、氏名等が表示されません。なぜでしょう?

昇順のコードはどのあたりに組めばいでしょうか?
コードはこんな感じでいいでしょうか?
教えてください。

Sub Macro1()
  Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
    :=xlPinYin
End Sub

【24497】Re:登録方法
回答  Hirofumi  - 05/4/23(土) 11:41 -

引用なし
パスワード
   >昇順のコードはどのあたりに組めばいでしょうか?
>コードはこんな感じでいいでしょうか?
>教えてください。
>
>Sub Macro1()
>  Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
>    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
>    :=xlPinYin
>End Sub

1、昇順にするコードは、必要有りません
 レコードを追加する度に、IDの昇順に行挿入される様にコードが組んで在ります
 ただし、既にListが有る場合、IDは昇順に並べられている必要は有ります

>事前に入力してあるIDを数値から文字列に揃えましたが、氏名等が表示されません。なぜでしょう?

2、IDが、文字列の所と数字だけの所が有るのですか?
 もし、現在数値として入力されている場合、セル書式を文字列にしても文字列とは
 成らず数値として認識されます
 この場合、1度、セル書式を文字列にして其のセル上でF2を押し編集にしてEnterを
 押します
3、このコードは、シート名が「Sheet1」として組んで有ります
 シート名と言うのは、シートのタブに表示されている名前の事で
 オブジェクト名のSheet1とは違う場合が有るので確認して下さい
4、このコードは、シート名Sheet1のA1からG1までの7列に列見出しが有る事が
 前提に成っています
5、もし駄目なら、1度、新規のBookに、UserFormを作り、
 シート名Sheet1のA1からG1までの7列に列見出しを作り
 試しに、レコードを作って見てください

【24498】Re:登録方法
回答  Hirofumi  - 05/4/23(土) 11:48 -

引用なし
パスワード
   もし、シート名が違う場合以下を修正して下さい

Private Sub UserForm_Initialize()

  'Listの先頭位置を設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

の、"Sheet1"を実状のシート名に変更して下さい

【24506】Re:登録方法
質問  まこと  - 05/4/23(土) 17:39 -

引用なし
パスワード
   ▼Hirofumi さん

ありがとうございました。
問題解決しました。

最後にもう一つだけ教えてください。
行の削除のところで、削除した行データと日付(年月日)を取得し
Sheet3に蓄積させたいのですが・・
教えてもらってばかりですが宜しくおねがいします。

Sheet3のイメージ
  A  B   C   D   E  F   G  H
1 ID 名前  *  *  *  *  * 削除日
2 *  *   *  *  *  *  * 2005/4/23  

【24508】Re:登録方法
回答  Hirofumi  - 05/4/23(土) 19:04 -

引用なし
パスワード
   「Private Sub CommandButton2_Click()」のプロシージャを以下の様に変更して下さい

Private Sub CommandButton2_Click()

'  行の削除

  Dim rngDelete As Range
  Dim lngWrite As Long

  '現在行が未定なら
  If lngCurrent = 0 Then
    Exit Sub
  Else
    If MsgBox(TextBox1.Text & "のデータが削除されます", _
        vbExclamation + vbOKCancel, "行削除") = vbOK Then
      '削除データのListの先頭セル位置を設定
      Set rngDelete = Worksheets("Sheet3").Cells(1, "A")
      With rngDelete
        'Sheet3のデータ書き込み位置を取得
        lngWrite = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
        If lngWrite < 1 Then
          lngWrite = 1
        End If
      End With
      With rngList.Offset(lngCurrent)
        '名簿Listの削除行を削除Listの最終行にCopy
        .Resize(, lngCoiumns).Copy _
            Destination:=rngDelete.Offset(lngWrite)
        'H列に日付を代入(コメントアウトの行は、時刻まで入れる場合)
        rngDelete.Offset(lngWrite, lngCoiumns).Value = Date
'        rngDelete.Offset(lngWrite, lngCoiumns).Value = Now
        '行を削除
        .EntireRow.Delete
      End With
      Set rngDelete = Nothing
    End If
    'List行数をディリメント
    lngRows = lngRows - 1
    'IDのセル範囲を更新
    Set rngSearch = rngList.Offset(1).Resize(lngRows)
  End If
    
  'TextBoxのデータをクリア
  TextBox1.Text = ""
  DataClear
  
End Sub

【24509】Re:登録方法
発言  Hirofumi  - 05/4/23(土) 19:14 -

引用なし
パスワード
   其れで、希望通り上手く動いたの?
回答者としては、そこら辺が聞きたいと思います?

【24510】Re:登録方法
発言  YN61  - 05/4/23(土) 20:03 -

引用なし
パスワード
   ▼Hirofumi さん:

今晩は、NY61です。
Hirofumi様の作成された
素晴らしいマクロを見させていただき、感激しています。
フォームに7項目のテキストボックスの配置に工夫して
有効に使えるデータを探したいくらいです。

コードが難解で、すぐには理解できませんが…。

削除後、シート3に、削除項目が記録される事も
何かこのような仕事があれば、凄く便利だと思います。

これからも、勉強させていただきたく思います。
ありがとうございました。

【24511】Re:登録方法
お礼  まこと  - 05/4/23(土) 20:36 -

引用なし
パスワード
   ▼Hirofumi さん:
こんばんは。
お返事遅れてすみません。
凄く感激しております。
今回は凄く凄く勉強になりました。
今度は、Hirofumiさんが作ってくださったコードを
勉強したいと思います。

また何かありましたらお願いします。

【24514】Re:登録方法
発言  サラリーマン  - 05/4/23(土) 22:27 -

引用なし
パスワード
   ▼Hirofumi さんへ
こんばんは。
はじめて、書かせていただきます。
今回たまたま名簿管理の質問が数件あったので参考にさせて頂いておりました。
わがままで申し訳ないのですが・

VBA初心者さん・まことさんの質問をドッキングすることは可能でしょうか?
フォーマットはVBA初心者さんのが理想です。(A列に会社名、B列にID)
VBA初心者さんのように会社選択後、IDが自動にふれて登録等ができ大変便利だと思うのですが宜しくお願いします。

VBA初心者さんの質問
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=24486;id=excel

【24515】Re:登録方法
質問  サラリーマン  - 05/4/23(土) 22:29 -

引用なし
パスワード
   間違いました。質問です
▼Hirofumi さんへ
こんばんは。
はじめて、書かせていただきます。
今回たまたま名簿管理の質問が数件あったので参考にさせて頂いておりました。
わがままで申し訳ないのですが・

VBA初心者さん・まことさんの質問をドッキングすることは可能でしょうか?
フォーマットはVBA初心者さんのが理想です。(A列に会社名、B列にID)
VBA初心者さんのように会社選択後、IDが自動にふれて登録等ができ大変便利だと思うのですが宜しくお願いします。

VBA初心者さんの質問
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=24486;id=excel

【24517】Re:登録方法
回答  Hirofumi  - 05/4/23(土) 23:15 -

引用なし
パスワード
   ▼サラリーマン さん:
>VBA初心者さん・まことさんの質問をドッキングすることは可能でしょうか?
>フォーマットはVBA初心者さんのが理想です。(A列に会社名、B列にID)
>VBA初心者さんのように会社選択後、IDが自動にふれて登録等ができ大変便利だと思うのですが宜しくお願いします。
>
>VBA初心者さんの質問
>http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=24486;id=excel

と言われても、何をどの様にドッキングするのでしょうか?
サラリーマンさんの頭の中には、イメージが出来ているのでしょうが
私には、サッパリイメージが沸きません?
サラリーマンさんが何を如何したいのか?、データが何処にどの様に有るのか?
等を詳しく説明をしていただけ無ければ、何とも回答のしようが有りません

【24523】サラリーマンさんの質問について
発言  Hirofumi  - 05/4/24(日) 7:05 -

引用なし
パスワード
   サラリーマンさん
後、Listの説明、動作の説明、データの説明等の詳しい仕様を書いて、
新規の質問にした方が善いと思います

この質問は、一応解決がついたみたいですし、
他の回答者さんの方が、私より上手いアイデアが有るかも解りません
また、私は土日ぐらいしか、まともに回答できませんので
速い回答が得られないと思います

【24524】Re:サラリーマンさんの質問について
発言  サラリーマン  - 05/4/24(日) 8:02 -

引用なし
パスワード
   Hirofumi さん
おはようございます

大変失礼いたしました。ついつい思うがままに
書いてしまいました。

9972 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free