[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ダブルクリックで通し番号入力』（RA）
初めて質問させて頂きます。
既存のリストに対して新しく通し番号を付与して並び替える場合
（既存リストの3番目を1番目にしたり、5番目を2番目にしたり…など）
手入力で新しい順番を入力し、並び替える必要があるかと思いますが…
その際にクリックした順に通し番号が入力できるみたいなことはできるのでしょうか？
＜ 使用 Excel：Office365、使用 OS：Windows 11 Home ＞
どういうリストか分かりませんが、
何かしらの基準でソートして、連番でふったほうが楽じゃないですか？
いくつあるか分かりませんが、いちいちダブルクリックはしんどくないですかね。
（tkit） 2022/08/25(木) 15:40
基準が非常に説明しにくいのですが…
例えば地図があって、その地図上にある家の全ての住所がリストになっており、
その住所リストを任意の順番に並べ替えたい場合にダブルクリックでなくとも
できるだけ効率よく作業を行いたいのです。。。
何か良い方法があれば…
（RA） 2022/08/25(木) 15:49
＞その住所リストを任意の順番に並べ替えたい 任意の順番に規則性は何かあるのでしょうか。 あればtkitさんの言う様にソートしてから振りなおした方が良いのでは
ダブルクリックして入力するくらいなら、片一方でマウス使ってセルクリックして もう一方を使ってテンキー入力しても変わらないと思います （なるへそ） 2022/08/25(木) 16:08
お返事ありがとうございます。
確かに規則性が有ればソートがかけられると思いますが、
現状、図面から状況を判断してそれに応じて順番に並び替えるという
流れなので、ソートが出来ず困っております。。。
リストに対して規則性が無いものを当方にて順番を割り振る作業を効率的に行うには…という認識です。
（RA） 2022/08/25(木) 16:20
通常はクリックなんて操作ミスしそうなものより、数字を入力していったほうが確実＆楽だと思います。 現状どういった不都合があってそういった要望に至ったのですか？ （.:*.ゆ ゅ） 2022/08/25(木) 16:27
お返事ありがとうございます
リストが8000件近くあり、図面とリストを見比べながら順番を割り振るのですが、リスト内を行ったり来たりスクロールする為、前の番号が画面上からいなくなってしまい、同じ数字を入力したり、次が何番目かわからなくなってしまう為、クリックで次の番号が入るようにした方がご入力が少ないかなと思いました。
（RA） 2022/08/25(木) 16:41
クリックはダメです。やめておいた方がいいです クリック＝選択なので ダブルクリックでやりましょう
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target(1), Me.Columns(1)) Is Nothing Then
Target(1).Value = Application.WorksheetFunction.Max(Me.Columns(1)) + 1
Cancel = True
End If
End Sub
8000件ダブルクリックする覚悟があるんですよね？ （´・ω・`） 2022/08/25(木) 16:51
＞既存のリストに対して新しく通し番号を付与して並び替える場合 ＞（既存リストの3番目を1番目にしたり、5番目を2番目にしたり…など）
雰囲気だけしか伝わって来ないです。 簡単な例で具体的に説明してください。
例えば、住所リストが以下だとして、 既存番の15を2番の下にしたい場合、何をどうするんですか？
少なくとも、15番と2番についての情報(2つ）が無いと新しい順に並べられないと思いますが。
行 ___A___ _________B_________ 1 既存番 住所 2 1 北海道 札幌市中央区 3 2 北海道 札幌市北区 4 3 北海道 札幌市東区 5 6 北海道 札幌市白石区 6 8 北海道 札幌市豊平区 7 9 北海道 札幌市南区 8 10 北海道 札幌市西区 9 11 北海道 札幌市厚別区 10 15 北海道 札幌市手稲区 11 20 北海道 札幌市清田区
なお、ダブルクリックは腱鞘炎になるので、私は右クリックがいいと思います。
（半平太） 2022/08/25(木) 17:00
その件数ダブルクリックすると腱鞘炎になりそうなので、 自分だったら1行目に現在入力している一番大きい数字を出すようにして、セル固定して作業しますね。 1行ぐらいだったら狭くなっても支障ないと思いますし… （.:*.ゆ ゅ） 2022/08/25(木) 17:01
お返事ありがとうございます。
とてつもない量ですが、必要な作業ですので頑張ります。。
ご参考にさせて頂きます！
（.:*.ゆ ゅ）様
確かに。。それは思いつきませんでした。。
手入力するならアリですね！
（半平太） 様
ご丁寧にありがとうございます
行 ___A___ _________B_________ 1 新規番 住所 2 4 北海道 札幌市中央区 3 1 北海道 札幌市北区 4 北海道 札幌市東区 5 3 北海道 札幌市白石区 6 北海道 札幌市豊平区 7 2 北海道 札幌市南区 8 北海道 札幌市西区 9 北海道 札幌市厚別区 10 北海道 札幌市手稲区 11 北海道 札幌市清田区
上記のように新規番号を手入力で入力している状態です
新規番号については住所から読み解ける規則性は無いです。
（実際には住所の並び替えではないですが…）
（RA） 2022/08/25(木) 17:11
>（既存リストの3番目を1番目にしたり、5番目を2番目にしたり…など） 3番目、5番目は欠番になり1番目、2番目は重複になりませんかね。
|[A]|[B] |[C]
[1]| 1| | 1
[2]| 2| | 2
[3]| 3| → | 1
[4]| 4| | 4
[5]| 5| | 2
違っていたらごめんなさい。 （???） 2022/08/25(木) 17:19
Dim WithEvents Lst As MSForms.ListBox
Private Sub Lst_Click()
'リストボックスクリック時の動作
If Lst.ListIndex > -1 Then 'リスト選択されているとき
Dim idx As Long
With ActiveCell
.Value = Lst.Value 'アクティブセルにリストの値を転記
.Offset(1).Activate 'アクティブセルを下に１つ移動
End With
idx = Lst.ListIndex 'リストインデックスの値を変数に入れる
Lst.ListIndex = -1 'リストの選択状態を解除
Lst.RemoveItem idx 'リストインデックスの値を削除
If Lst.ListCount < 1 Then 'リストが空になったら
Unload Me 'フォームを閉じる
End If
End If
End Sub
Private Sub UserForm_Initialize()
'ユーザーフォーム起動時の動作
Dim ListRange As Range
Dim i As Long
On Error Resume Next 'リスト範囲を選択
Set ListRange = Application.InputBox("リスト範囲を選択してください", Type:=8)
On Error GoTo 0
If Not ListRange Is Nothing Then 'リスト範囲が選択されているとき
Set Lst = Me.Controls.Add("Forms.ListBox.1", "WordList") 'フォーム上にリストボックスを作成
With Lst
.Left = 6 'リストボックスの左座標
.Top = 6 'リストボックスの上座標
.Width = WorksheetFunction.Max(ListRange.Width, 80) 'リストボックスの幅。最低80
.Height = WorksheetFunction.Min(ListRange.Height, 240) 'リストボックスの高さ。最高240
.Font.Size = ListRange(1).Font.Size 'リストボックスのフォントサイズをリスト範囲先頭に合わせる
For i = 1 To ListRange.Rows.Count 'あとで削除できるようにリスト項目を一つずつ登録
If ListRange(i).Value <> "" Then 'リスト空白を無視
.AddItem ListRange(i).Value 'リストに追加
End If
Next
'ユーザーフォームの大きさをリストボックスに合わせる
Me.Width = .Width + Me.Width - Me.InsideWidth + .Left * 2
Me.Height = .Height + Me.Height - Me.InsideHeight + .Top * 2
End With
End If
End Sub
練習課題のつもりで書いてみました。
フォームモジュールにコピペしてください。
実行前にカーソルを住所を書き込む範囲の先頭セルに合わせてください。
実行すると範囲選択を求められるので住所一覧を選択してください。
そのあと住所リストが出てきます。クリックした住所がセルに書き込まれリストから消えます。
リストの住所を全部選択するか×ボタンでフォームが消えます。
8000件も一度に入れられるかわかりませんが・・・
（下手の横好き） 2022/08/25(木) 17:20
ありがとうございます。
既存で順番はなく、単純にリストがあるだけです。
そのリストに対して今回順番を付与していく作業ですので、順番の
重複は当方が同じ番号を入力してしまわない限りないですね！
（下手の横好き）様
お手数おかけして申し訳ございません。。
ありがとうございます！
当方の作業の詳細について、
説明不足で申し訳ないのですが、
8000件に対して1〜8000で通し番号を付与するわけではなく、
A地区（100件）：1〜100の通し番号
B地区（300件）：1〜300の通し番号
C地区（250件）：1〜250の通し番号
・
・
・
全地区の合計で8000件といった感じです。。
（RA） 2022/08/25(木) 17:33
C列に新たな連番を入れるとする
__|___A____|___B____|___C____ 1|Data |元順 |新順 2|A005 | 1| 3|A007 | 2| 4|A004 | 3| 5|A008 | 4| 6|A002 | 5| 7|A006 | 6| 8|A010 | 7| 9|A009 | 8| 10|A003 | 9| 11|A001 | 10|
「A001」が1番の場合、[C11]に数式「=ROW()-1」を設定。 と同時に[A1:C11]をC列昇順で並び替える
With [A1:C11]
If Intersect(ActiveCell, .Columns(3)) Is Nothing Then Exit Sub
ActiveCell.Formula = "=ROW()-1"
.Sort "新順", XlSortOrder.xlAscending, Header:=xlYes
End With
↓こんな感じになる
__|___A____|___B____|___C____ 1|Data |元順 |新順 2|A001 | 10| 1 3|A005 | 1| 4|A007 | 2| 5|A004 | 3| 6|A008 | 4| 7|A002 | 5| 8|A006 | 6| 9|A010 | 7| 10|A009 | 8| 11|A003 | 9|
続けて 「A002」が2番の場合、[C7]に数式「=ROW()-1」を設定。 と同時に[A1:C11]をC列昇順で並び替える
__|___A____|___B____|___C____ 1|Data |元順 |新順 2|A001 | 10| 1 3|A002 | 5| 2 4|A005 | 1| 5|A007 | 2| 6|A004 | 3| 7|A008 | 4| 8|A006 | 6| 9|A010 | 7| 10|A009 | 8| 11|A003 | 9|
以下同様に連番を設置していく
__|___A____|___B____|___C____ 1|Data |元順 |新順 2|A001 | 10| 1 3|A002 | 5| 2 4|A003 | 9| 3 5|A004 | 3| 4 6|A005 | 1| 5 7|A006 | 6| 6 8|A007 | 2| 7 9|A008 | 4| 8 10|A009 | 8| 9 11|A010 | 7| 10
連番付け終わったら、C列を定数化してしまって、 必要であればB列昇順で並び替える事で、データは元の並び順に戻せる。
__|___A____|___B____|___C____ 1|Data |元順 |新順 2|A005 | 1| 5 3|A007 | 2| 7 4|A004 | 3| 4 5|A008 | 4| 8 6|A002 | 5| 2 7|A006 | 6| 6 8|A010 | 7| 10 9|A009 | 8| 9 10|A003 | 9| 3 11|A001 | 10| 1
という作業イメージを妄想中...
（白茶） 2022/08/25(木) 18:22
だんだん、やるべき事が分かってきました。
私としては、並べ替えを本当にやるのは負担が大きいと考えます。
ある行(例：10行目にあった）が、次の処理の順番(例：作業としては3行目に移動すべきもの）だと決まったら、 3行目のデータを一時的に退避してから、10行目のデータを3行目に上書きする。 そこに新順を追加記入する。(白茶さんのアイデアの通り）
その後、温存して置いたデータを10行目に上書きする。
これなら、1件処理するのに、2行の書き換えだけで済みます。
（半平太） 2022/08/25(木) 18:49
あとは、A地区、B地区、・・の区別をどうつけるのかですねぇ。
いままでの説明では、この部分はほとんど説明されていない。 地区別にどう並んでいるのかさえ不明。
RAさんの追加説明を待ちたい。
（半平太） 2022/08/25(木) 19:19
ありがとうございます。
元の順番に並び替えたりは必要ないので、あくまで順番をいかにサクサク入力するための入力支援を考えています。
1件に対しては、1クリックもしくは順番入力の1アクションの方がイメージ的には助かります。。。
すいません。。。
（半平太）様
お返事遅くなり、すいませんでした。
うまく伝わるかわかりませんが。
例として住所と地区を用いて説明させていただくと、
Ａ列 Ｂ列 Ｃ列
順番 地区 住所
３ Ａ あ
２ Ａ い
１ Ａ う
４ Ａ え
１ Ｂ あ
３ Ｂ か
２ Ｂ き
４ Ｂ く
２ Ｃ け
１ Ｃ こ
上記の様な感じで地区と住所のリストがあり、
地区内における住所を任意の順番に並び替えるためにＡ列に順番項目を作り、入力しています
・地区違いの同一住所もあります
・それぞれの地区は30〜200件くらいあります
・地区ごとに1〜の通し番号を付けたいです
図面を見ながらリストに通し番号でサクサク入力していきたいのですが、トータルの件数があまりに多いので…少しでも1件にかかる時間の低減の為の入力支援と誤防止の為のダブルクリックだけで連番付与が出来ないかと悩んでおります。
当方のイメージとしては、リストと図面を見比べながらＡ列をポチポチするだけで押した順番に自動で通し番号が出てくれたらなぁと思いながら作業しております。
皆さん親切で大変恐縮です。。。
すいません。
（RA） 2022/08/25(木) 20:16
先に順番を振り、最後に１回だけ並べ替えをすればいい話なんですね？
すると、作業途中では地区別にいちいち、1から連番にする必要性はないです。(最後にやればいい）
以下の構想でよければマクロを作ります(明日。その前に別案が提示されれば、そちらにお任せします。）
<初期状態> → <振り番途中の状態> → 全て番号を振った後、地区・順番で昇順に並べ替え
順番 地区 住所 順番 地区 住所 順番 地区 住所
Ａ あ ３ Ａ あ 1 Ａ う
Ａ い ２ Ａ い 2 Ａ い
Ａ う １ Ａ う 3 Ａ あ
Ａ え ４ Ａ え 4 Ａ え
Ｂ あ ５ Ｂ あ 5 Ｂ あ
Ｂ か Ｂ か 6 Ｂ き
Ｂ き ６ Ｂ き 7 Ｂ か
Ｂ く ↑ Ｂ く 8 Ｂ く
Ｃ け ｜ Ｃ け 9 Ｃ こ
Ｃ こ ｜ Ｃ こ 10 Ｃ け
｜
｜
└順位の高い方の住所セルを右クリックすると、
それまでの最大順位に+１した順位をA列に出す(マクロで自動）。
仕上げで下図の様に地区別連番に振り直す(マクロで自動)。
行 __A__ __B__ __C__
1 順番 地区 住所
2 1 Ａ う
3 2 Ａ い
4 3 Ａ あ
5 4 Ａ え
6 1 Ｂ あ
7 2 Ｂ き
8 3 Ｂ か
9 4 Ｂ く
10 1 Ｃ こ
11 2 Ｃ け
なので、「自動順番振りマクロ」と「自動並べ替えマクロ」の2種類を作ることになります。
（半平太） 2022/08/25(木) 21:30
右クリック(Worksheet_BeforeRightClick)で連番入力にしましたが、ダブルクリック(Worksheet_BeforeRightClick)でも同じです。
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim c As Range
Set c = Intersect(Columns(1), Target)
If c Is Nothing Then Exit Sub
If c.Cells.Count > 1 Then Exit Sub
If c.Value <> "" Then Exit Sub
c.Value = WorksheetFunction.MaxIfs(Columns(1), Columns(2), c.Offset(, 1)) + 1
Cancel = True
End Sub
（hatena） 2022/08/25(木) 23:16
Dim WithEvents Lst As MSForms.ListBox Dim ListRange As Range
Private Sub Lst_Click()
'リストボックスクリック時の動作
If Lst.ListIndex > -1 Then 'リスト選択されているとき
Dim idx As Long
idx = Lst.ListIndex 'リストインデックスの値を変数に入れる
Cells(Lst.List(idx, 0), 1).Value = WorksheetFunction.MaxIfs(ListRange.Columns(1).Cells, ListRange.Columns(2).Cells, Lst.List(idx, 1)) + 1
'A列に地区別最大値＋１の値を入力
Lst.ListIndex = -1 'リストの選択状態を解除
Lst.RemoveItem idx 'リストインデックスの値を削除
If Lst.ListCount < 1 Then 'リストが空になったら
Unload Me 'フォームを閉じる
End If
End If
End Sub
Private Sub UserForm_Initialize()
'ユーザーフォーム起動時の動作
Dim i As Long
Set ListRange = Range("A2", Cells(Rows.Count, "C").End(xlUp)) 'リスト範囲を選択
Set Lst = Me.Controls.Add("Forms.ListBox.1", "WordList") 'フォーム上にリストボックスを作成
With Lst
.Left = 6 'リストボックスの左座標
.Top = 6 'リストボックスの上座標
.Width = WorksheetFunction.Max(3 + ListRange.Columns(2).Width + ListRange.Columns(3).Width, 80)
'リストボックスの幅。最低80
.Height = WorksheetFunction.Min(ListRange.Height, 240) 'リストボックスの高さ。最高240
.ColumnCount = 3 'リストボックスを2列にする
.ColumnWidths = "0;" & ListRange.Columns(2).Width & ";" & _
ListRange.Columns(3).Width 'リストボックス内のそれぞれの列幅
.Font.Size = ListRange(1, 3).Font.Size 'リストボックスのフォントサイズをリスト範囲先頭に合わせる
For i = 1 To ListRange.Rows.Count 'あとで削除できるようにリスト項目を一つずつ登録
If ListRange(i, 3).Value <> "" Then 'リスト空白を無視
.AddItem "" 'リストに追加
.List(i - 1, 0) = ListRange(i, 1).Row
.List(i - 1, 1) = ListRange(i, 2).Value
.List(i - 1, 2) = ListRange(i, 3).Value
End If
Next
'ユーザーフォームの大きさをリストボックスに合わせる
Me.Width = .Width + Me.Width - Me.InsideWidth + .Left * 2
Me.Height = .Height + Me.Height - Me.InsideHeight + .Top * 2
End With
End Sub
RAさんの表に合わせてマクロを書き換えてみました。
（下手の横好き） 2022/08/26(金) 09:57
Dim WithEvents Lst As MSForms.ListBox Dim ListRange As Range
Private Sub Lst_Click()
'リストボックスクリック時の動作
If Lst.ListIndex > -1 Then 'リスト選択されているとき
Dim idx As Long
idx = Lst.ListIndex 'リストインデックスの値を変数に入れる
Cells(Lst.List(idx, 0), 1).Value = WorksheetFunction.MaxIfs(ListRange.Columns(1).Cells, ListRange.Columns(2).Cells, Lst.List(idx, 1)) + 1
'A列に地区別最大値＋１の値を入力（抜け番補正無し）
Lst.ListIndex = -1 'リストの選択状態を解除
Lst.RemoveItem idx 'リストインデックスの値を削除
If Lst.ListCount < 1 Then 'リストが空になったら
Unload Me 'フォームを閉じる
End If
End If
End Sub
Private Sub UserForm_Initialize()
'ユーザーフォーム起動時の動作
Dim i As Long, iCnt As Long
Set ListRange = Range("A2", Cells(Rows.Count, "C").End(xlUp)) 'リスト範囲を選択
Set Lst = Me.Controls.Add("Forms.ListBox.1", "WordList") 'フォーム上にリストボックスを作成
With Lst
.Left = 6 'リストボックスの左座標
.Top = 6 'リストボックスの上座標
.Width = WorksheetFunction.Max(3 + ListRange.Columns(2).Width + ListRange.Columns(3).Width, 80)
'リストボックスの幅。最低80
.Height = WorksheetFunction.Min(ListRange.Height, 240) 'リストボックスの高さ。最高240
.ColumnCount = 3 'リストボックスを2列にする
.ColumnWidths = "0;" & ListRange.Columns(2).Width & ";" & _
ListRange.Columns(3).Width 'リストボックス内のそれぞれの列幅
.Font.Size = ListRange(1, 3).Font.Size 'リストボックスのフォントサイズをリスト範囲先頭に合わせる
For i = 1 To ListRange.Rows.Count 'あとで削除できるようにリスト項目を一つずつ登録
If ListRange(i, 3).Value <> "" And _
ListRange(i, 1).Value = "" Then 'リスト空白と順番が空白でない行を無視
.AddItem "" 'リストに追加
.List(iCnt, 0) = ListRange(i, 1).Row
.List(iCnt, 1) = ListRange(i, 2).Value
.List(iCnt, 2) = ListRange(i, 3).Value
iCnt = iCnt + 1
End If
Next
'ユーザーフォームの大きさをリストボックスに合わせる
Me.Width = .Width + Me.Width - Me.InsideWidth + .Left * 2
Me.Height = .Height + Me.Height - Me.InsideHeight + .Top * 2
End With
End Sub
すでに順番入力済みの行をリストから抜くことにしました。
（下手の横好き） 2022/08/26(金) 10:16
>A地区（100件）：1〜100の通し番号 地区ごとですよね。 >上記の様な感じで地区と住所のリストがあり 地区が混在していますよね。 どちらが正しいのですか。 （???） 2022/08/26(金) 11:33
興味が湧いたので、作ってみました。 ショートカットキーに設定してください。 また、ヘッダ行、地区の列、番号入力の列をご自身の環境に合わせてコードを書き換えてください。
イメージは、 番号入力したいセルの行ならどこでもいいのでマウスで選択。 ショートカットキーを押す。 です。
複数のセルを選択した場合、アクティブセル(起点のセル)の地区のみ対象とします。 飛び飛びで選択した場合、選択した順で連番が入力されていきます。 ドラッグで複数選択した場合、アクティブセル(起点のセル)を起点に昇順、又は降順で、 連番が入力されていきます。 ※ 結構、手作業での効率を考え作りましたので、試してみてください。
Sub Numbering()
'▼ヘッダ行指定
Dim headerRow As Long
headerRow = 1
'▼地区の列指定:あえて文字列にしています。列記号A〜を指定
Dim groupColumn As String
groupColumn = "B"
'▼番号入力の列指定:あえて文字列にしています。列記号A〜を指定
Dim numberingColumn As String
numberingColumn = "A"
If TypeName(Selection) <> "Range" Then Exit Sub
Dim groupValue As String
groupValue = Cells(ActiveCell.Row, groupColumn).Value
Dim lastRow As Long
lastRow = Cells(Rows.Count, groupColumn).End(xlUp).Row
Dim dataBodyRow As Long
dataBodyRow = lastRow - headerRow + 1
Dim groupTemp As Variant
Dim numberingTemp As Variant
Dim groupCount As Long
With Cells(headerRow + 1, groupColumn).Resize(dataBodyRow, 1)
groupTemp = Application.Transpose(.Value)
groupCount = Application.CountIf(.Cells, groupValue)
End With
numberingTemp = Application.Transpose(Cells(headerRow + 1, numberingColumn).Resize(dataBodyRow, 1).Value)
Dim i As Long
Dim cnt As Long
Dim maxNum As Long
For i = LBound(groupTemp) To UBound(groupTemp)
If groupTemp(i) = groupValue Then
Select Case True
Case IsEmpty(numberingTemp(i))
Case IsNumeric(numberingTemp(i))
If numberingTemp(i) > maxNum Then maxNum = numberingTemp(i)
End Select
cnt = cnt + 1
If cnt >= groupCount Then Exit For
End If
Next i
Dim pasteNum As Long
pasteNum = maxNum + 1
Dim rng As Range
Dim startIndex As Long
Dim endIndex As Long
Dim n As Long
Dim pasteRow As Long
For Each rng In Selection.Areas
Select Case rng.EntireRow(1).Row = ActiveCell.Row
Case True
startIndex = 1
endIndex = rng.EntireRow.Count
n = 1
Case Else
startIndex = rng.EntireRow.Count
endIndex = 1
n = -1
End Select
For i = startIndex To endIndex Step n
pasteRow = Selection.EntireRow(i).Row
If Cells(pasteRow, groupColumn).Value = groupValue Then
With Cells(pasteRow, numberingColumn)
If Len(.Value) = 0 Then
.Value = pasteNum
pasteNum = pasteNum + 1
End If
End With
End If
Next i
Next rng
End Sub
（tkit） 2022/08/26(金) 11:52
こんにちは、もうお腹いっぱいかもしれないな…(笑) 多くの方が提案をされていると…したくなる衝動に駆られますね。いざ…挑戦!! ^^;
・先頭行は、見出しがあるようなので、ウィンドウ枠で先頭行を固定します。 ・B列の地区別アルファベットは、エクセル標準搭載のフィルター機能で 昇順に予め...並び替えて起きます。
|[A] |[B] |[C] |[D]|[E]|[F]
[1] |順番|地区|住所 | | 3|B
[2] | |A |A地区1-1
[3] | |A |A地区1-2
[4] | |A |A地区1-3
[5] | 1|B |B地区1-1
[6] | 3|B |B地区1-3
[7] | 2|B |B地区1-2
[8] | |C |C地区1-1
[9] | |C |C地区1-2
[10]| |C |C地区1-3
・8000行程あると、対象地区範囲を下までスクロールするのも手間なので F1セルに入力規則で地区選択を可能にして、F1セルをダブルクリックすると 対象地区範囲の先頭行までスクロールさせます。
・また、F1セルに入力規則で地区選択を可能にするのは...8000行程あると、 A列への入力が重くなってしますかと思うので、範囲選択を可変にして 動作を軽くします。
・各地域の通し番号は、1〜300もあると...どこまでカウントを入力したか わからなくなるので、E1セルへカウントアップ数値がでるようにします。
・ダブルクリックすると、指が疲れるのでA列を選択すると カウントアップさせ、入力するようにします。 ただし、E1セルの数値+1...がA列選択セルに入力されます。
・F1セルに地区を選択すると、対象の地区のA列だけに 入力が入るようにします。(誤防止の為) A列を飛び飛びで選択した場合、選択した順で連番を入力します。
・他の地区を間違って選択しても、E1セルのカウントアップはされませんが F1選択された地区を再度選択(A列)すると…E1セルのカウントアップはされてしまいます。 ・E1セルの初期化は、F1セルをダブルクリックすると…空白セルになります。
◇対象のシートモジュールに以下のマクロを入れて試してみてください。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ClickSelection As Range, MyRNG As Range
Dim FirstCell As Range, LastCell As Range
If Intersect(ActiveCell, Columns(1)) Is Nothing Then Exit Sub
If Target.CountLarge <> 1 Then Exit Sub
Set FirstCell = Columns(2).Find(Range("F1").Value, After:=Range("B" & Rows.Count))
Set LastCell = Columns(2).Find(Range("F1").Value, After:=FirstCell, SearchDirection:=2)
Set ClickSelection = Range(FirstCell, LastCell).Offset(, -1)
If Intersect(Target, ClickSelection) Is Nothing Then Exit Sub
Range("E1").Value = Range("E1").Value + 1
For Each MyRNG In Range(FirstCell, LastCell)
Target.Value = Range("E1").Value
Next MyRNG
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Registered_District As Variant
If Not Intersect(Target, Range("F1")) Is Nothing Then
Range("E1").Value = ""
Cancel = True
End If
If Not Range("F1").Value = Empty Then
Set Registered_District = Columns(2).Find(Range("F1").Value, LookIn:=xlValues)
If Not Registered_District Is Nothing Then
Registered_District.Activate
Else: MsgBox "登録地区はありません"
Range("F1").Value = Empty
End If
End If
End Sub
※A列の入力が終了したら、フィルターでA列→B列を並び替えれば、終了です。
（あみな） 2022/08/26(金) 13:03
仕事に追われ、返事が遅くなって本当に申し訳ありません…
初めてここを知り質問させてもらいましたが、いつの間にか
たくさんの方が具体的な提案をしていただき本当に恐縮です…
当方素人なのでひとつずつ確認して、自分にしっくりくるものが
あれば有難く使わせてもらいます！！
ジュース奢る機能あれば全員に奢ります！
（RA） 2022/08/26(金) 17:10
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.