[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『サンプル貸出管理表』（あっちゃん）
お世話になります。
サンプル貸出管理表を作成したいと思います。
初心者なので、過去ログを拝見させて頂きましたが、応用ができず、また、
[[20040701173628]]『レンタル商品の出入りをエクセルで管理できますか』（わこ）
[[20040113132539]]『図書貸出管理表を作りたい』（HIRO)
とは、私が思っているものと少し違うので教えて下さい。（日付を縦に入力している点、書込シートのデータは初期化（？）して、転記シートのデータは累積する点など）
今は、貸出サンプル（２３個）の日程表を手作業で、表（1日を1列）にオートシェープ（矢印）にて描いています。
私が考えていますのは
sheet １ 入力用 sheet ２ 日程表
とし、
sheet １に条件を入力したら、sheet ２の該当日に「＝」という記号がでるようにしたいのです。
sheet １には、
Ａ Ｂ
１ 項目１ 項目２
２ 商品名 入力規則によるデーター入力（カゴ１、カゴ２、ザル１、ザル２ など）
３ 希望状態 入力規則によるデーター入力（社内にて か 社外にて）
４ 期間始 手入力 ○月○日
５ 期間至 手入力 ×月×日
６ 貸出会社 手入力
７ 担当者 手入力
を入力し、それを受けて
８ 結果 「貸出できません か 貸出できます」とか出したい。
そして、sheet ２には、
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ
１空セル 8/1 8/2 8/3 8/4 8/5 8/6 8/7 ２カゴ１ == === === === ３貸出会社 ▲▲▲企画 ■■会社 ４担当者 田中一郎 佐藤五郎 ５カゴ２ === ６貸出会社 ▲▲▲企画 ７担当者 田中二郎 ８カゴ３ == === === === ９貸出会社 ▲▲▲企画 10担当者 田中三郎
希望は、
１．sheet ２の日付の所に、sheet １で入力された日（開〜至 何日間か）に「=」を付けたい。 ２．「=」も社内か社外かによって色分けしたい。 ３．sheet ２にて、カゴ１のように新たに貸出しする場合の初日に会社名や担当者をその下に自動記入。 ４．新規にファイルを開けたらsheet １の入力されたデータは消え、新たに商品名が選択できる状態にしたい。 （sheet ２のデータは累積させたい） ５．sheet ２の記録は、６ヶ月程残したい。 ６．今日現在、貸出中の商品の商品名のセルを色で塗る。 このようなことができますでしょうか？ 何卒 よろしく御願い致します。
VBAを使った方が良さそうに思えます・・・・
(INA)
まったく、わかりません。
どのようにしたらよいのでしょうか？
お教え願えないでしょうか？
宜しく御願いします。（あっちゃん）
数式は苦手なので、VBAを使わないで出来るのか分からないですが、 まず仕様を明確にした方がよいです。
> ８ 結果 「貸出できません か 貸出できます」とか出したい。 これの判定基準は何でしょうか？
(INA)
Sheet1の必要項目が入力されたら Sheet2の内容をもとに貸出可・不可の判定をするのは 数式で行ったほうが良いと思います。 以下、試作品。「Sheet2が出来ていれば」これでいいはずです。
=IF(COUNTA(B2:B7)=6,IF(COUNTIF(OFFSET(Sheet2!A1,MATCH(B2,Sheet2!A2:A100,0),MATCH(B4,INDIRECT("Sheet2!B1:IV1"),0),1,B5-B4+1),"*=*"),"貸出出来ません","貸出できます"),"")
（ ６．）の色づけも条件付書式でできるので、マクロからは除外できます。 問題はSheet2のデータをつくるマクロですね。 昨晩考えていたのですが、タイムアウト。 (KAMIYA)
自分なりに、貸出可･不可については、LOOKUP を使ってみたのですがダメでした。
IF関数の組合わせですか−。さすが〜という感じです。（゜o゜）やってみます。
（６．）のは、あっそうか！って感じです。すみません。（m_m）
（５．）については、人が必要性を判断し、１つずつ確認しながら手で削除します。
すみませんでした。
申し訳ありませんが、１〜４の項目について、教えて下さい。
宜しく御願いします。（あっちゃん）
あっちゃんさんはVBAがお嫌いのようなので、 そしたら関数をお教えしまひょか、と申し上げたいところですが、 わたしにゃそんな酔狂な知識はおまへんねん、残念ながら。 なんぼ何でもコレを全て関数でまかなう事は難しいんとちゃいまっか。（根性ある 御方が居てますさかい、断言はでけまへんけどナ）（笑）
で、その、お嫌いなVBAによる方法ですけど、まぁ、いっぺん遊んでみなはれ。 1)新しいブックを開く 2)[Alt]+[F11]でVBEを開く 3)「挿入」→「標準モジュール」を選択 4)真新しいモジュールに下のコードをコピペ 5)エクセルに戻る 6)Sheet2のB1から右方向に日付(文字列はダメ）を記入（適当に） 7)sheet1を開いてA、B列にそれぞれの項目を書き込んでくだはい。 8)A8の結果欄は無くてもかまいまへん。本番ではKAMIYAはんの数式を利用すれば ええと思います。
Sheet1のB列が埋まったら[Alt]+[F8]でtensouを実行してみてくだはい。 Sheet2を開いてみれば、どうでっか？ご希望のデータが書き込まれてまっしゃろ。 また、Sheet1に戻ってデータを書き込んで何度も試してくだはい。 貸し出し中のサンプルをB2に書き込んだら「貸し出しNO」のメッセージが出るように なっとります。
Sheet1にコマンドボタンを作ってそのコードにtensouと書き込めば実用的になるでせう
１つだけお願いしたいのは、何度も確認しながらゆっくり上の作業を進めてくだはい。
（弥太郎）
'--------------------------------------------
Option Explicit 'この２行はGeneral Declarationsで
Dim ws1 As Worksheet, ws2 As Worksheet
'---------------------------------------------
Sub tensou()
Rem 変数の宣言
Dim maxrow As Long, match_row As Long
Dim match_col As Integer
Dim find_data1, find_data2
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Rem 変数の初期化
match_row = 0
Rem もしSheet1のB2〜B7に空白セルがあればメッセージを流して
'マクロ終了
If WorksheetFunction.CountA(ws1.Range("b2:b7")) <> 6 Then
MsgBox "入力が不完全です", vbExclamation
Exit Sub
Rem 空白セルが無いばやい
Else
Rem Sheet1のB4の値がB5より大きかったら入力ミスを指摘（ココ追加）
If ws1.Cells(4, 2) > ws1.Cells(5, 2) Then
MsgBox "期間始と終わりの入力が不完全です", vbExclamation
ws1.Cells(4, 2).Select
Exit Sub
End If
Rem Sheet2の記入簡素化
With ws2
Rem Sheet2A列の最下行プラス1を（新規入力行）取得
maxrow = .Range("a65536").End(xlUp).Row + 1
Rem エラーを無視して次のコードを実行
On Error Resume Next
Rem Sheet1B2の値をSheet2のA列から検索してその行番号を変数に格納
match_row = WorksheetFunction.Match(ws1.Cells(2, 2), .Range("a1:a" & maxrow), 0)
Rem もし一致するデータがあれば
If match_row > 0 Then
Rem 期間始のデータをSheet2の１列目から〜データの存在する最終列
'まで検索し、そのデータを変数に格納
match_col = WorksheetFunction.Match(ws1.Cells(4, 2), _
.Range(.Cells(1, 1), .Cells(1, .Cells(, 256).End(xlToLeft).Column)), 0)
Rem もし一致したセルに===があればメッセージを流して終了
If .Cells(match_row, match_col) <> "" Then
MsgBox "貸し出し出来ません", vbExclamation
Exit Sub
End If
End If 'match_row > 0 Then の終了
Rem シート間をウロウロするな（処理速度が上がる）
Application.ScreenUpdating = False
Rem 期間始と期間至のデータをそれぞれの変数に格納
find_data1 = ws1.Cells(4, 2)
find_data2 = ws1.Cells(5, 2)
Rem もしws1のB2のデータがws2のA列になければ新規データを
'ws2の然るべき行に出力
If match_row = 0 Then
.Cells(maxrow, 1) = ws1.Cells(2, 2)
.Cells(maxrow + 1, 1) = ws1.Cells(6, 1)
.Cells(maxrow + 2, 1) = ws1.Cells(7, 1)
Rem 引数を従えてサブルーチンに作業を委託
Call work(find_data1, find_data2, maxrow)
Rem データがあればmatch_row（一致をみた行No）を別の変数
'に入れ替えて（サブルーチンの作業簡素化のため）
'サブルーチンに飛ぶ
Else
maxrow = match_row
Call work(find_data1, find_data2, maxrow)
End If
Rem ws2の入力簡素化終わり
End With
Rem 最初のIf文終了
End If
ws1.Range("b2:b7").ClearContents ' ws1のデータを消去
ws1.Range("b2").Select 'B2にポインターを合わせて次の入力を待つ
Application.ScreenUpdating = True 'ウロウロOK
On Error GoTo 0 'エラー処理の終了
End Sub
'------------------------------
Rem サブルーチン
Sub work(find_data1, find_data2, maxrow)
Dim i As Integer
Dim tbl As Range
With ws2
Rem ws2の２列目からデータのある最終列数までループ
For i = 2 To .Cells(, 256).End(xlToLeft).Column
Rem もし変数（期間始）がws2の1行i列目のデータと一致したら
'その変数にiの値を格納しws2の合致した１行下に
'貸出会社を、更にもう１行下に担当者名を出力
If find_data1 = .Cells(1, i) Then
find_data1 = i
.Cells(maxrow + 1, find_data1) = ws1.Cells(6, 2)
.Cells(maxrow + 2, find_data1) = ws1.Cells(7, 2)
End If
Rem もし変数（期間至）がws2の1行目i列目と合致したら
'その変数にiの値を格納してループを抜け出す
If find_data2 = .Cells(1, i) Then
find_data2 = i
Exit For
End If
Next i 'iの値が満たされるまでForに戻って作業
Rem 変数に必要なセル番地を一括りにする
Set tbl = .Range(.Cells(maxrow, find_data1), .Cells(maxrow, find_data2))
Rem そのグループに===を入力
tbl.Value = "'==="
Rem もしws1のB3に社内が入力されていたら
'グループの===を赤に、他の文字なら青にする
If ws1.Cells(3, 2) = "社内" Then
tbl.Font.ColorIndex = 3
Else
tbl.Font.ColorIndex = 5
End If
End With
Set tbl = Nothing 'グループの解放
End Sub
肝心な事言うのん忘れてましたワ。 社内外をどう判断してええか分かりまへんのんで、とりあえず社内は 社内 社内以外は全て社外として作業してます。 上のコードClearをClearContentsに変更しました。 （弥太郎）
申し訳有りません。（m_m）（m_m）
弥太郎様に教えて頂いたコードを『落ち着いて、確実に行ってみたい』と思います。
どうか、お時間を下さい。（完了するのが明日以降なる可能性が･･･）
今から、自分に納得させながら、１つ１つ実行して行きます。
そこで、判らないことが出来ましたら、また教えて下さい。
宜しく御願いします。（あっちゃん）
わざと、データを一部未入力にしたら、メッセージボックスで、「入力が不完全です。」と出て、感動！
今度は、全ての項目（sheet １ B2:B7 ）の6データを入力！
さぁ！ ？？？ 転記しない！？
「貸し出し出来ません」とメッセージがでます。
えっ？まだ、１つもデータ入力していないよ？！
弥太郎様によると、日付データは sheet ２ B2 より右へ
自分の設定は、A2から右へ！
あっこれだ！と思い修正しましたが、
やはり、「貸し出し出来ません」の文字が。
コードの意味を少しお教え願えませんか？
どうして、動いてくれないのか考えてみたいので。（でも、理解できないかも・・・）（T_T）
宜しく御願いします。（あっちゃん）
あっちゃん様、こんばんは！！ 私も作ってみました。 少し？お望みのものとは違うかもしれませんが。。 入力用のシートと1月から12月までのシート計13枚を用意して下さい。 入力用のシートには 項目1 項目2 商品名 カゴ2 希望状態 社内にて 期間始 2004/11/10 期間至 2004/11/15 貸出会社 qqq 担当 aaaaa と入力されているとして。。 1月から12月までのシートには、、 1月1日 1月2日 カゴ1 貸出会社 担当者 カゴ2 貸出会社 担当者 カゴ3 貸出会社 担当者 こんな感じで入力されているとします。
'ご希望５．sheet ２の記録は、６ヶ月程残したい。 'シートの見出し（自分の名前）より6ヶ月以上経過すると左端一列と最上段一行を残してデータを削除する。
↓これを1月から12月までのシートに貼り付けます。
Private Sub Worksheet_Activate()
Dim MyMonth As Long
Dim MyStr As Long
MyStr = InStr(1, Me.Name, "月")
MyMonth = DateDiff("m", DateSerial(Year(Date), Val(Left(Me.Name, MyStr - 1)), Day(Date)), Date)
If MyMonth = 6 Or MyMonth = -6 Then
With Range("A1").CurrentRegion
.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).ClearContents
End With
End If
End Sub
↓これを入力用のシートに貼り付けます。
'C1をたたくとマクロを実行します。。。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim MyRow As Double
Dim MySDate As Date, MyEDate As Date
Dim MySCol As Integer, MyECol As Integer
Dim MyCol As Integer, W As Long, MyIndex As Long
Dim MySYear As Integer, MyEYear As Integer
Dim MySMonth As Integer, MyEMonth As Integer, MyMonth As Integer
Dim MySDay As Integer, MyEDay As Integer
Dim Flag As Boolean, C As Range, i As Integer, R As Range
If Target.Address <> "$C$1" Then Exit Sub
Cancel = True
'日付のチェック
If Not IsDate(Cells(4, 2).Value) Or Not IsDate(Cells(5, 2).Value) _
Or Cells(4, 2).Value > Cells(5, 2).Value Then
MsgBox "日付に誤りがあります。"
Range(Cells(4, 2), Cells(5, 2)).ClearContents
Exit Sub
End If
With Me
MySDate = .Cells(4, 2).Value
MyEDate = .Cells(5, 2).Value
MySYear = Year(.Cells(4, 2).Value)
MyEYear = Year(.Cells(5, 2).Value)
MySMonth = Month(.Cells(4, 2).Value)
MyEMonth = Month(.Cells(5, 2).Value)
MySCol = Day(.Cells(4, 2).Value)
MyECol = Day(.Cells(5, 2).Value)
End With
'入力のチェック
With Me
For Each C In .Range("B2:B7")
If C.Value = "" Then
MsgBox C.Offset(, -1).Value & "が未入力です。。"
Exit Sub
End If
Next
End With
'フラグを立ててシートの有無をチェック
For MyMonth = 1 To 12
For W = 1 To Worksheets.Count
Flag = False
If Worksheets(W).Name = (MyMonth & "月") Then
Flag = True
Exit For
End If
Next
If Flag = False Then Exit For
Next
If Flag = False Then
MsgBox MyMonth & "月のシートがありません。"
Exit Sub
End If
'シートがあったら
If Flag = True Then
With Sheets(MySMonth & "月")
On Error Resume Next
MyRow = Application.WorksheetFunction.Match( _
Cells(2, 2), .Range("A1", .Range("A65536").End(xlUp)), 0)
If Err.Number = 1004 Then
On Error GoTo 0
MsgBox MySMonth & "月に " & Cells(2, 2) & " はありません。"
Exit Sub
End If
End With
'貸出しのチェック
With Sheets(MySMonth & "月")
i = 0
For Each R In .Range(.Cells(MyRow, MySCol + 1), .Cells(MyRow + 2, MySCol + 1))
If R.Value <> "" Then
i = i + 1
End If
Next
If i = 3 Then
MsgBox "既に貸し出しされています。。。" & Chr(13) & Chr(13) & _
"貸出し会社は " & .Cells(MyRow + 1, MySCol + 1).Value & Chr(13) & _
"担当は " & .Cells(MyRow + 2, MySCol + 1).Value & Chr(13) & Chr(13) & "です。"
Exit Sub
ElseIf i = 1 Then
MsgBox "貸し期間中です。" & Chr(13) & Chr(13) & _
"貸出し開始日を変更してください。"
Exit Sub
End If
End With
'ご希望２．「=」も社内か社外かによって色分けしたい。
'色の振り分け
If Cells(3, 2).Value = "社内にて" Then
MyIndex = 5
ElseIf Cells(3, 2).Value = "社外にて" Then
MyIndex = 3
End If
'開始と終了が同じ月の場合
'同月内の処理
'ご希望１．sheet ２の日付の所に、sheet １で入力された日（開〜至 何日間か）に「=」を付けたい。
'ご希望３．sheet ２にて、カゴ１のように新たに貸出しする場合の初日に会社名や担当者をその下に自動記入。
If MySMonth = MyEMonth Then
With Sheets(MySMonth & "月")
.Cells(MyRow + 1, MySCol + 1).Value = Cells(6, 2).Value
.Cells(MyRow + 2, MySCol + 1).Value = Cells(7, 2).Value
.Cells(MyRow, MySCol + 1).Resize(, 1 + MyECol - MySCol).Value = "="
.Cells(MyRow, MySCol + 1).Resize(, 1 + MyECol - MySCol).Font.ColorIndex = MyIndex
End With
'開始月の方が大きい場合、つまり年をまたぐ場合の処理
'開始月の処理
ElseIf MySMonth > MyEMonth Then
With Sheets(MySMonth & "月")
MySDay = Day(DateSerial(MySYear, MySMonth + 1, 1) - 1)
.Cells(MyRow + 1, MySCol + 1).Value = Cells(6, 2).Value
.Cells(MyRow + 2, MySCol + 1).Value = Cells(7, 2).Value
.Cells(MyRow, MySCol + 1).Resize(, 1 + MySDay - MySCol).Value = "="
.Cells(MyRow, MySCol + 1).Resize(, 1 + MySDay - MySCol).Font.ColorIndex = MyIndex
End With
'開始が12月以外の場合
If MySMonth < 12 Then
'開始から11月まで
For MyMonth = MySMonth + 1 To 12
MySDay = Day(DateSerial(MySYear, MyMonth + 1, 1) - 1)
With Sheets(MyMonth & "月")
.Cells(MyRow + 1, 2).Value = Cells(6, 2).Value
.Cells(MyRow + 2, 2).Value = Cells(7, 2).Value
.Cells(MyRow, 2).Resize(, MySDay).Value = "="
.Cells(MyRow, 2).Resize(, MySDay).Font.ColorIndex = MyIndex
End With
Next
End If
'1月から終了前月までの処理
If MyEMonth > 1 Then
For MyMonth = 1 To MyEMonth - 1
MyEDay = Day(DateSerial(MyEYear, MyMonth + 1, 1) - 1)
With Sheets(MyMonth & "月")
.Cells(MyRow + 1, 2).Value = Cells(6, 2).Value
.Cells(MyRow + 2, 2).Value = Cells(7, 2).Value
.Cells(MyRow, 2).Resize(, MyEDay).Value = "="
.Cells(MyRow, 2).Resize(, MyEDay).Font.ColorIndex = MyIndex
End With
Next
End If
'終了月の処理
With Sheets(MyEMonth & "月")
.Cells(MyRow + 1, 2).Value = Cells(6, 2).Value
.Cells(MyRow + 2, 2).Value = Cells(7, 2).Value
.Cells(MyRow, 2).Resize(, MyECol).Value = "="
.Cells(MyRow, 2).Resize(, MyECol).Font.ColorIndex = MyIndex
End With
Else
'年内の処理
'開始月の処理
With Sheets(MySMonth & "月")
MySDay = Day(DateSerial(MySYear, MySMonth + 1, 1) - 1)
.Cells(MyRow + 1, MySCol + 1).Value = Cells(6, 2).Value
.Cells(MyRow + 2, MySCol + 1).Value = Cells(7, 2).Value
.Cells(MyRow, MySCol + 1).Resize(, 1 + MySDay - MySCol).Value = "="
.Cells(MyRow, MySCol + 1).Resize(, 1 + MySDay - MySCol).Font.ColorIndex = MyIndex
End With
'中間月の処理
For MyMonth = MySMonth + 1 To MyEMonth - 1
MySDay = Day(DateSerial(MySYear, MyMonth + 1, 1) - 1)
With Sheets(MyMonth & "月")
.Cells(MyRow + 1, 2).Value = Cells(6, 2).Value
.Cells(MyRow + 2, 2).Value = Cells(7, 2).Value
.Cells(MyRow, 2).Resize(, MySDay).Value = "="
.Cells(MyRow, 2).Resize(, MySDay).Font.ColorIndex = MyIndex
End With
Next
'終了月の処理
With Sheets(MyEMonth & "月")
.Cells(MyRow + 1, 2).Value = Cells(6, 2).Value
.Cells(MyRow + 2, 2).Value = Cells(7, 2).Value
.Cells(MyRow, 2).Resize(, MyECol).Value = "="
.Cells(MyRow, 2).Resize(, MyECol).Font.ColorIndex = MyIndex
End With
End If
End If
'ご希望４．新規にファイルを開けたらsheet １の入力されたデータは消え、新たに商品名が 選択できる状態にしたい
Me.Range("B2:B7").ClearContents
End Sub
データを全て入力した後に入力シートのC1をダブルクリックするとマクロを実行します。
ちょっと、べたべたのコードなので、、今回は、どんどん、、バシバシ、、叩いてください (>_<)
で、どうでしょう？
あっ、、ご希望六まであったのね？ご希望六は宿題とさせてください。。m(__)m
（夏目雅子似）
おっ、ライバル登場！！ ゴメン、雅子はん似のコードの検証は後回しにして（笑） Sheet2のA1は空セルでB1から右へでしたワ。エライスンマヘン。 Sheet1のB4,B5のデータ及びSheet2の１行目は文字列での記入はあきまへん。 Sheet1のB4,B5のデータとSheet2の１行目を照合する（両方文字列ならOK）ように なっておりますから文字列は避けてくだはい。 コードの意味は私のコードに付け加えておきました。
あ、それから、これは余談ですけどもう一つのコードねえ。 ダブルクリックすると指がつるなんて持病があるんやったら、アレ、止めとった方が ええですよ。（笑） ほな...（弥太郎）
お陰様で、上司に誉められ（ちゃんとある方に教えて頂きましたと報告はしました）アメ（本物の）を貰ってしまいました。
そして、毎日使わして頂いています。ありがとう。
今回の sheet １「入力用シート」はパソコンを触ったことがない人ばかりがいる他部署の人に入力してもらうということで、シートは１つにしたいのです。BOOKは共有でも。
申し訳有りません。せっかく考えて頂きましたのに（m_m）（T_T）
ですが、私では考えつかなかった言葉「既に貸し出しされています」「貸出会社は」「担当は」「貸出期間中です」「貸出期間を変更して下さい」とか、いいな〜と思いました。
さすが！
弥太郎様
早速ありがとうございました。
全て、コピーし動かしましたがダメでした。
また sheet １ と sheet ２ のセルの日付設定はしています。
弥太郎様が、考えて下さったコードを努力して理解します。
少々、お時間を下さい。宜しく御願いします。（のろまで勉強不足のあっちゃん）
おはようございます。 前回の説明は見苦しくなっとりましたんで、新たに書き換えときましたワ。 前のんを没にして改めてコピペし直して貰うたら見易くてええと思いまっせぇ。 なお （ココ追加）と有りますのんはエラー処理を追加しときました。 ほな...（弥太郎）
申し訳ないことに、今日は他の仕事でいっぱいいっぱいです。
何せ、要領（？）容量（？）が少ないので。（m_m）
もう少し、時間を下さい。（m_m）（m_m）
（超のろまなあっちゃん）
ここまで力作のマクロだと、ちょっと試してみるのも大変なので サンプルブックをネット上にあげてもらえると嬉しいですね。（希望）
(INA)
何分にも初心者で利用の方法が分かりません。
こんな私にでも出来ることがあったら、教えて下さい。
また、余談なのですが、最近「エクセルの学校」を自分のパソに「名前をつけて保存」と行っても、真っ白何も保存されません。
どのようにすれば、従来通り保存ができるのでしょうか？（あっちゃん）
弥太郎様
申し訳ありません。
私の説明不足で。
実はsheet ２には、
日付
商品名
は、すでに入力していて、
sheet １
B2（商品名）
B4（貸出始）〜B5（貸出至）の条件のあった所に「===」をつけたかったです。
弥太郎様は、商品名の入力の手間も省いて下さってのですね！
気がつくのが遅くて、ごめんなさい。
Sheet ２を日付のみの入力にし、やってみました。
ばっちりです！完璧です。動きました！
動かなかった原因は、私が始めに入力していた商品名sheet １とsheet ２に違いがありました。（商品名の数字を半角全角とか）
ところで、またまた贅沢を言って申し訳ないのですが・・・。
予約を取り消すときはどうすればよいのでしょうか？
Sheet ２全体に保護をかけたいので、直接sheet ２を担当者が触るというのは、困るのですが。
何卒宜しく お願い致します。（あっちゃん）
まこです。とても勉強になっています。感謝です。
>INA様がおっしゃっておられます、サンプルブックをネット上に〜って、私が何かするのですか？ サンプルブックをネット上におく方法ですが、 【ヤフーブリーフケース】http://briefcase.yahoo.co.jp/ Yahoo Japan IDを持っている方が利用できます。30MBまでのファイルをアップすることが可能です。 【インターネットディスク】http://www.idisk-just.com/start.html 一太郎やATOKで有名なジャストシステムが運営しています。有料ですが、2GBまでのファイルをアップすることができます。
ファイルを公開したり、自宅と会社でファイルを持ち運んだり、メールでは添付できないような大きなデータを配布したりする場合などに便利です。
もしよろしかったらどうぞ。
「エクセル質問ボード」の部分を保存したいのなら、 「エクセル質問ボード」のリンク文字を右クリックして 「新しいウィンドウで開く」を選択して、「エクセル質問ボード」を表示してから 保存すればよいと思います。 または、保存したいフレームで右クリックし、「ソースの表示」でメモ帳などに表示された ソースを「名前を付けて保存」でファイル名に拡張子「.html」をつけて保存する。 といった方法ではいかがでしょうか? Netscapeでは「このフレームを名前を付けて保存」とかできます。ブラウザによって 異なるので、上はIEの場合ということで・・・ (Hatch)
まこ様、ということは、この「エクセルの学校」で、私がねばならない（つまり義務発生）ということでなければ、これについてはこれからの課題ということで研究させて頂きます。
教えて下さってありがとうございました。
保存できました。感謝です。
また、宜しく お願い致します。 （あっちゃん）
まこさん フォロー有り難う御座います。 複雑な内容のときは質問者・回答者ともにブックをWEB上にアップすると 分かり易くてよいかなと思って書きました。
あっちゃんさん 義務とかではなく、インターネットを有効活用するとより便利 というだけで、 「課題」「研究」なんて大げさなものではないです。
(INA)
INA様 悪い意味には取らないで下さいね。
ネットの利用方法がわからずウロウロ。
何とか今後も、色々教えて頂きたい（「エクセルの学校」を利用させて頂きたい）と思い・・・。
皆様にご迷惑をおかけしない利用方法が判りません。
ねばならない（義務発生）が出てきたりしたら、ネット常識が判らないので、これからも色々教えて下さい。
何卒 宜しく御願いします。（あっちゃん）
> サンプルブックをネット上にあげてもらえると嬉しいですね。(INA) これは、多分私に上のサンプルをダウンロードコーナーに置いてほしいという 意味だと思います。
具体的に[弥太郎さん]さんと[夏目雅子似]さんと2つありますが、 2つともアップしましょうか？
（kazu）
kazuさんへ めっそうもないです。 管理者のkazuさんに、お手間をとらせる意味ではなかったのです。 投稿時に写真をアップできる掲示板などもありますので、 そのような感じでブックをアップできると便利だと思いました。 しかしそれは掲示板システムによるものなので 各自で、まこさんが書いて下さったようなyahooブリーフケースのようなものを 利用することにより、よりスムーズに質問（問題）を解決できればと思いました。 もし仮に掲示板のシステムで出来たとしても へんなマクロブックを誰でもダウンロードできる状況になってしまうと トラブルにも繋がってしまいそうですし。
あっちゃんさんへ 直接質問と関係のない投稿をして記事を長くしてしまい ご迷惑お掛けしました。ごめんなさい。m(__)m
(INA)
kazu様にも、ご迷惑をおかけして申し訳ありませんでした。
ところで、また、弥太郎様 お時間がありましたら、予約取消の方法をお教え下さい。
宜しく お願い致します。（あっちゃん）
あっちゃんさん、返事遅うなってごめんなはれや。 選りに選って、今日から仕事なんですワ。 で、帰ってきたら、はい、ビールを飲んでオリンピックの観戦でっしゃろ。 もう野球の方は（オリンピックでない方の）諦めてますさかい、観る気もしまへんけど 4年に1度の祭典を見逃す訳には参りまへんのんや。 尤もロクに観んうちに鼾かいとるんがオチですけどなぁ。（笑）
まぁ、任せときなはれ。手ぇ付けた以上はちゃんと始末は付けたげまんがな。 ほないに大層にコードをいじらんでもイケますさかい大丈夫でっせ。（おい、足下 ふらついとる） それにマクロに余念の無い若い連中が腕まくりしてスキを伺うてますさかいナ、こりゃ 弥太郎はんアテにならんで、と判断したらキチンと面倒みてくれますますワ、ハイ。 あのぅ、コホン、今日はもう寝ます。（弥太郎））
うれしいです。
何かお気に障ったことを書いてしまったのかな？と不安でした。よかった！ホッ！
オリンピックですか〜.私も手に汗を握りながら・・・。
大船に乗った気で安心していつまでもお待ちしていますので、ゆっくり観戦して下さい。
宜しく お願い致します。（あっちゃん）
おはようございます。
後で弥太郎さんが素敵なのを作ってくれると思いますが、私なりに作ってみましたので
よかったら試してみてください。
今回は、シート1とシート2だけで、シート2のB1から右に日付を入力してから実行してみて
ください。でも、私のことだから動くかどうかわかりませんがぁ、、汗^^;汗
駄目だったらごめんなさいm(__)mということで、、ではでは。
（夏目雅子似）
Sub サンプル出荷()
Dim MySCol As Double, MyECol As Double, MyRow As Double
Dim MyMinDay As Double, MyMaxDay As Double, X As Double, Y As Double
Dim C As Range, MyItem As String
Dim MaxRow As Long, MyIndex As Long, MyAnser As Long
Dim Wsh1 As Worksheet, Wsh2 As Worksheet
Set Wsh1 = Worksheets("Sheet1")
Set Wsh2 = Worksheets("Sheet2")
MaxRow = Wsh2.Range("A65536").End(xlUp).Row
MyItem = Wsh1.Cells(2, 2).Value
'入力のチェック
With Wsh1
For Each C In .Range("B2:B7")
If C.Value = "" Then
MsgBox C.Offset(, -1).Value & "が未入力です。。"
Exit Sub
End If
Next
'日付のチェック
If Not IsDate(.Cells(4, 2).Value) Or Not IsDate(.Cells(5, 2).Value) _
Or .Cells(4, 2).Value > .Cells(5, 2).Value Then
MsgBox "日付に誤りがあります。"
.Range(.Cells(4, 2), .Cells(5, 2)).ClearContents
Exit Sub
End If
End With
On Error Resume Next
With Wsh2
'Sheet2のレンタル管理期間日をチェック
MyMinDay = Application.WorksheetFunction.Min(.Range("B1", .Range("IV1")))
MyMaxDay = Application.WorksheetFunction.Max(.Range("B1", .Range("IV1")))
If Wsh1.Cells(4, 2).Value < MyMinDay Or Wsh1.Cells(5, 2).Value > MyMaxDay Then
If MyMinDay <= 1 And MyMaxDay <= 1 Then
MsgBox "レンタル管理期間日が設定されていません。" & Chr(13) & Chr(13) & _
"Sheet2のB1からIV1の範囲にレンタル管理期間日を設定してください。", vbExclamation
Exit Sub
End If
MsgBox "開始〜終了日が適応範囲外です。" & Chr(13) & Chr(13) & _
Format(MyMinDay, "yyyy/mm/dd") & "から" & Chr(13) & _
Format(MyMaxDay, "yyyy/mm/dd") & "までの期間を指定して下さい。", vbExclamation
Wsh1.Range(Cells(4, 2), Cells(5, 2)).ClearContents
Exit Sub
End If
'適応する行及び開始列終了行を取得
MyRow = Application.WorksheetFunction.Match( _
Wsh1.Cells(2, 2), .Range(.Cells(1, 1), .Cells(65536, 1).End(xlUp)), 0)
MySCol = Application.WorksheetFunction.Match( _
Wsh1.Cells(4, 2), .Range(.Cells(1, 1), .Cells(1, 256)), 0)
MyECol = Application.WorksheetFunction.Match( _
Wsh1.Cells(5, 2), .Range(.Cells(1, 1), .Cells(1, 256)), 0)
On Error GoTo 0
'商品があった場合に貸出し期間をチェック
If MyRow > 0 Then
'開始終了共に空白ではない場合
If .Cells(MyRow, MySCol).Value <> "" And .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
If .Cells(MyRow + 1, MyECol + 1).Value = "" And .Cells(MyRow + 2, MyECol + 1) = "" Then
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1) = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
End If
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 3 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
'開始日が空白じゃない場合
ElseIf .Cells(MyRow, MySCol).Value <> "" Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 3 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
X = X - 1
'終了日が空白じゃない場合
ElseIf .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1).Value = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
Y = Y + 1
'開始日と終了日の間が空白ではない場合
ElseIf Application.WorksheetFunction.CountA( _
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol))) > 0 Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
X = X - 1
Y = Y + 1
Else
GoTo MyLine
End If
MyAnser = MsgBox(MyItem & "は、貸し出し中または貸出し期間が設定されています。" _
& Chr(13) & Chr(13) & _
"開始日は " & Format(.Cells(1, Y).Value, "yyyy/mm/dd") & Chr(13) & _
"終了日は " & Format(.Cells(1, X).Value, "yyyy/mm/dd") & Chr(13) & _
"貸出し会社は " & .Cells(MyRow + 1, Y).Value & Chr(13) & _
"担当は " & .Cells(MyRow + 2, Y).Value & " です。" & Chr(13) & Chr(13) & _
"このデータを削除して新規に登録しますか？" & Chr(13) & Chr(13) & _
"キャンセルを押すとこのデータを削除して終了します。。。。", vbInformation + vbYesNoCancel)
Select Case MyAnser
Case vbYes
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Case vbNo
Exit Sub
Case vbCancel
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Wsh1.Range("B2:B7").ClearContents
Exit Sub
End Select
End If
MyLine:
'社内か社外かで色分け
If Wsh1.Cells(3, 2).Value = "社内にて" Then
MyIndex = 5
ElseIf Wsh1.Cells(3, 2).Value = "社外にて" Then
MyIndex = 3
End If
'商品がなかったら、最下部に追加して転記
If MyRow = 0 Then
.Cells(MaxRow + 1, 1).Value = Wsh1.Cells(2, 2).Value
.Cells(MaxRow + 2, 1).Value = Wsh1.Cells(6, 1).Value
.Cells(MaxRow + 3, 1).Value = Wsh1.Cells(7, 1).Value
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Value = "="
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Font.ColorIndex = MyIndex
.Cells(MaxRow + 2, MySCol).Value = Wsh1.Cells(6, 2).Value
.Cells(MaxRow + 3, MySCol).Value = Wsh1.Cells(7, 2).Value
Else '商品があったらその行に転記
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Value = "="
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Font.ColorIndex = MyIndex
.Cells(MyRow + 1, MySCol).Value = Wsh1.Cells(6, 2).Value
.Cells(MyRow + 2, MySCol).Value = Wsh1.Cells(7, 2).Value
End If
End With
Wsh1.Range("B2:B7").ClearContents
Wsh1.Range("B2").Select
Set Wsh1 = Nothing
Set Wsh2 = Nothing
End Sub
2004/8/24 10:41
諸般の事情によりパソコンが一瞬しか使えないので、今マクロを実行させて頂くことができません。月曜日までお時間を下さい。
申し訳ありません。
また先日、「予約取付」もしたいという希望も追加してしまったのです。
「予約取付」については、sheet １ A列の８番目に「予約」、B列に「新規」か「取付」かを選択できる入力規則による入力をしたいと思います。←すみません。「取付」でなく「取消」でした。
追加希望についてのコードについても教えて頂けますか？
また、不慣れな担当者が入力する関係で、マクロを実行し、「貸出できる状態」（====）の時、何もしないで、上書き保存するコードも追加して頂けませんか？
色々後々になって、注文が多く申し訳ありません。
宜しく お願い致します。（あっちゃん）
あっちゃんさん、遅うなってメンゴ。 あんさんの優しいお心遣いでオリムピックを堪能させて貰とります、おおきに。
さて、全角半角の入力間違いでも処理でけるように変更しましたんやけど、 このサンプルを１品種１個でっしゃろ？ このマクロはそう解釈して作っとりますけど、何となく複数存在するような気ぃが・・
予約の取り消し（取り付けやおまへんやろ？）のデータは商品名と期間始のデータだけ で充分ですワ。期間至の行(B5)にキャンセルを入力して貰てコマンドボタンを（作って いなければtensouを実行）クリックしたらOKデス。 あんまり検証してまへんからようわかりまへんけど、色んなケースを考えて検証して みてくだはい。 なお、シートの保護は考えてまへん。競合するとアカンので前のマクロは削除しとって くださいヨ。 （弥太郎） なお、殴り込みをかけてきた雅子似はんのマクロがよければあん人のんを使うたって くだはい。 '------------------------------ Dim flag As Boolean Dim ws1 As Worksheet, ws2 As Worksheet '-------------------------------- Sub tensou()
Dim maxrow As Long, match_row As Long, t As Long
Dim match_col As Integer, Rtn As Integer
Dim find_data1, find_data2, data
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
flag = False
If WorksheetFunction.CountA(ws1.Range("b2:b7")) <> 6 And ws1.Cells(5, 2) <> "キャンセル" Then
MsgBox "入力が不完全です", 48
Exit Sub
Else
If ws1.Cells(5, 2) = "キャンセル" Then
Rtn = MsgBox("このデータの予約をキャンセルしますか？", 4)
If Rtn = vbNo Then
ws1.Cells(5, 2) = ""
ws1.Cells(5, 2).Select
Exit Sub
Else
If ws1.Cells(2, 2) = "" Or ws1.Cells(4, 2) = "" Then
MsgBox "キャンセルデータが不明です", 48
Exit Sub
Else
flag = True
End If
End If
End If
If ws1.Cells(4, 2) > ws1.Cells(5, 2) Then
MsgBox "期間始と終わりの入力が不完全です", 48
ws1.Cells(4, 2).Select
Exit Sub
End If
With ws2
maxrow = .Range("a65536").End(xlUp).Row + 1
On Error Resume Next
data = StrConv(ws1.Cells(2, 2), vbNarrow)
For t = 2 To maxrow Step 3
If data = StrConv(.Cells(t, 1), vbNarrow) Then
match_row = t
Exit For
End If
Next t
If match_row > 0 Then
match_col = WorksheetFunction.Match(ws1.Cells(4, 2), _
.Range(.Cells(1, 1), .Cells(1, .Cells(, 256).End(xlToLeft).Column)), 0)
If flag = True And .Cells(match_row, match_col) = "" Then
MsgBox "キャンセルデータが不明です", 48
Exit Sub
Rem もし貸し出し不能のメッセージが不要で、なにもせずに終了したいばやい
'は下の３行を削除して
'Else
' Exit Sub
'とする
ElseIf WorksheetFunction.CountIf(.Rows(match_row), "*=*") <> 0 And flag <> True Then
MsgBox "貸し出し出来ません", 48
Exit Sub
End If
End If
Application.ScreenUpdating = False
find_data1 = ws1.Cells(4, 2)
find_data2 = ws1.Cells(5, 2)
If match_row = 0 Then
.Cells(maxrow, 1) = ws1.Cells(2, 2)
.Cells(maxrow + 1, 1) = ws1.Cells(6, 1)
.Cells(maxrow + 2, 1) = ws1.Cells(7, 1)
Call work(find_data1, find_data2, maxrow)
Else
maxrow = match_row
Call work(find_data1, find_data2, maxrow)
End If
End With
End If
ws1.Range("b2:b7").ClearContents
ws1.Range("b2").Select
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
'-------------------------------
Sub work(find_data1, find_data2, maxrow)
Dim i As Integer
Dim tbl As Range
With ws2
For i = 2 To .Cells(, 256).End(xlToLeft).Column
If find_data1 = .Cells(1, i) Then
find_data1 = i
If flag = True Then
Call can_cel(find_data1, maxrow)
Exit Sub
Else
.Cells(maxrow + 1, find_data1) = ws1.Cells(6, 2)
.Cells(maxrow + 2, find_data1) = ws1.Cells(7, 2)
End If
End If
If find_data2 = .Cells(1, i) Then
find_data2 = i
Exit For
End If
Next i
Set tbl = .Range(.Cells(maxrow, find_data1), .Cells(maxrow, find_data2))
tbl.Value = "'==="
If ws1.Cells(3, 2) = "社内" Then
tbl.Font.ColorIndex = 3
Else
tbl.Font.ColorIndex = 5
End If
End With
Set tbl = Nothing
End Sub
'----------------------------
Sub can_cel(i, maxrow)
Dim n As Integer
n = i
With ws2
Do
n = n + 1
If .Cells(maxrow, n) = "" And .Cells(maxrow + 1, n) = "" Then
Exit Do
End If
Loop While .Cells(maxrow, n) <> ""
.Cells(maxrow, i).Resize(3, n - 1).Clear
End With
End Sub
４年に１度の祭典を、私なんかのために・・・。
もったいない！でも、ちょっとは堪能できたご様子なので、ホッとしました。
弥太郎様のおっしゃる通り、「取付」ではなく「取消」です。
またまた、うっかりで申し訳ありません。
はずかしい〜（>_<）
色々なパターンを作成し、月曜日にでも一度使わせて頂きたいと思います。
ご迷惑をおかけして申し訳ありませんでした。（あっちゃん）
あっちゃんさん、今日は仕事が早う終わりましたんで、ちょっと検証してみたら
早速不具合が１個所見つかりましたワ。
キャンセル作業の所ですけどわナ、貸し出し初日を指定せなメッセージが流れるよう
にしたつもりやったんですけど、それ以降の日付を指定してもそこから消去してしま
うみたいなんで、
If flag = True And .Cells(match_row, match_col) = "" Then
MsgBox "キャンセルデータが不明です", 48
Exit Sub
の所を
If flag = True And (.Cells(match_row, match_col) = "" Or .Cells(match_row + 1, _
match_col) = "") Then
MsgBox "キャンセルデータが不明です", 48
ws1.Cells(2, 2).Select
Exit Sub
に差し替えてくれしまへんか。 今んとこそれくらいですけど、また不具合があればカキコしとってくだはい。 余談ですけど、オリムピックの方は充分堪能しとります。おおきに。 ほな...（弥太郎）
昨日のマラソンすごかったですね。
実は、午前中からやらせて頂いていまして、？？？のところが（゜_゜：）？
サンプルは２３個しかありません。
その２３個を貸出したり、返却してもらったりしています。
つまり、サンプル１は、色々なお客様のもとでお仕事をしてきます。
そこで
弥太郎様に前回作って頂いたコードは、
仮に
１度め予約入力
sheet １
機種名 サンプル１
期間 始 8/22
至 8/23
２度目予約入力
機種名 サンプル１
期間 始 8/30
至 8/31
と入力すれば、サンプル１の対象となる日付（２箇所）のところに「＝＝＝」が入りました。
今回は、上記のようなことを入力したら２度目予約の時「貸し出しできません」とでます。
前回のように、して頂きたいのですが。
宜しく御願いします。
また、夏目似様
夏目様のコードも貼り付けてみました。（もち別ＢＯＯＫで）
「開始日と終了日の間が空白ではない場合」のコードで
If vbYes = MsgBox(MyItem & "は、貸し出し中または貸出し期間が設定されています。" _
& Chr(13) & Chr(13) & _
"開始日は " & Format(.Cells(1, Y).Value, "yyyy/mm/dd") & Chr(13) & _
"終了日は " & Format(.Cells(1, X).Value, "yyyy/mm/dd") & Chr(13) & _
"貸出し会社は " & .Cells(MyRow + 1, Y).Value & Chr(13) & _
"担当は " & .Cells(MyRow + 2, Y).Value & " です。" & Chr(13) & Chr(13) & _
"このデータを削除して新規に登録しますか？", vbExclamation + vbYesNo) Then
で実行エラー1004が出ます。
？？？
また、宜しく御願いします。（あっちゃん）
ElseIf WorksheetFunction.CountIf(.Rows(match_row), "*=*") <> 0 And flag <> True Then
MsgBox "貸し出し出来ません", 48
Exit Sub
コレを消せば前の貸し出しデータに関係なくInputされますけど、
「貸し出しできません」の条件はなんっでっしゃろ？
貸出日が重複したばやいのみ貸し出し不可になるんでっか？
（弥太郎）
そのサンプルが貸し出されている日がすでに「予約」の状態、つまり、貸出日が重複した場合のみ「貸し出しできません」としたいのです。
上記のコードを消せばこの条件が満たされますか？（あっちゃん）
すみません。上のコードを訂正しておきましたので試してみてください。 （夏目雅子似）
はい、はい。
削除してと言うたコードを
ElseIf flag <> True And .Cells(match_row, match_col) <> "" Then
MsgBox "貸し出し出来ません", 48
Exit Sub
で、いけます、はい。
気ぃ効かしたつもりが悪い方に転んだみたいで・・・。どんまい、どんまい。
そしたらcan_celのコードもチョットいじらなあきまへんのんで差し替えておくんなは
れ。
Sub can_cel(i, maxrow)
Dim n As Integer
n = i
With ws2
Do
n = n + 1
If (.Cells(maxrow, n) = "" And .Cells(maxrow + 1, n) = "") _
Or (.Cells(maxrow, n) = "===" And .Cells(maxrow + 1, n) <> "") Then
Exit Do
End If
Loop While .Cells(maxrow, n) <> ""
.Cells(maxrow, i).Resize(3, n - 2).Clear
End With
End Sub
マラソン良かった〜（弥太郎）
もうばっちり！サンプル１に重複しない日付のデータが入りました。
ありがとうございました。
これに、今度は条件付書式（TODAYのデータに薄緑）をいれてみます。
また、つまったら、是非宜しくお願い致します。
夏目似様、ありがとうございます。
夏目似様のコードで サンプル１の１度目の予約は入力できました。
サンプル１に重複しない日付のデータ２度目の予約を入れると
「開始日と終了日の間が空白ではない場合」のコードで
If vbYes = MsgBox(MyItem & "は、貸し出し中または貸出し期間が設定されています。" _
& Chr(13) & Chr(13) & _
"開始日は " & Format(.Cells(1, Y).Value, "yyyy/mm/dd") & Chr(13) & _
"終了日は " & Format(.Cells(1, X).Value, "yyyy/mm/dd") & Chr(13) & _
"貸出し会社は " & .Cells(MyRow + 1, Y).Value & Chr(13) & _
"担当は " & .Cells(MyRow + 2, Y).Value & " です。" & Chr(13) & Chr(13) & _
"このデータを削除して新規に登録しますか？", vbExclamation + vbYesNo) Then
で実行エラー1004が出ます。
？？？また、宜しく御願いします。（あっちゃん）
度々すみません。訂正しましたので試してみてください。 （夏目雅子似）
バッチリ入りました。
サンプル１に重複しない日付のデータが入りました。
あの〜予約取消の時はどうすればよいのでしょうか？
また 教えて下さい。宜しく お願い致します。（あっちゃん）
こんばんは！あっちゃんさん、何度も間違えてごめんなさいねm(__)m 途中でコードを見直した時に勘違いしたみたいです。(^_^; ところで、キャンセルですね？ 私のコードは既にあるデータと新規のデータを置き換えるか？というものですから、 MsgBoxに「はい」と「いいえ」に加えて「キャンセル」を追加しました。 文字通り「キャンセル」をクリックすると、既存のデータを消去して終了します。 コードは上のコードを修正しています。。。。 で、どうでしょう？ （夏目雅子似）
夏目似様 ありがとうございます。
「予約取消」できました。ありがとう。
そこで、また御願いなのですが〜.
「予約取消」完了時には、sheet １のデータを消せたらな〜とか思います。
お手数ですが、宜しく御願いします。（あっちゃん）
あっちゃんさん、おはようございます。 上のコードを修正しておきましたので、試して見てください。 （夏目雅子似）
昨日カキコ頂いていたのですね？
私は、勘違い（自分がカキコした時間を記憶違い）をし「まだ返事が頂けていない、お忙しいのかな？」などと、昨日の昼から今まで何度も「エクセルの学校」を開いては閉じということを繰り返していました。またまた早とちりをしてしまいました。（^_^:A
お蔭様で、新しいコードうまくいきました。
ありがとうございました。
大変申し上げにくいことですが、下記の２つについてお願いしたいのです。
なにせ、私以上にパソオンチが触るので１件１件の予約が完了する度に、「上書き保存」をしたいのです。
そのうえ、わたしのわがままで、また少しフォーマットを変更したいのですが〜.
Sheet １とsheet ２、各々最前列に１列、最前行に５行挿入（表題と項目説明と注意書きなど用）をしたいのです。
つまり
sheet １ 機種 →B7
形態（社内・社外選択）→B8 〜
担当者 →（B12）
上記の答えというかデータを各対象行のC列 に
sheet ２ 日付 →C6 〜右へ
sheet １からの転記事項 →B7 〜
申し訳ありませんが、何卒宜しくお願い致します。（あっちゃん）
ちょっと、あっちゃんさん、そらぁ、なんぼなんでもいきすぎっちゅうもんでっせ。 あんさんが勝手にフォーマットを変更したいと仰有るんやったら、雅子はんの説明 を頼りにご自分でやってみるんが筋というもんやおまへんか？ それとも、夏目さんに何らかの報酬を用意しとるとでもいうんでっか？ それならそれで商談成立っちゅう事になって、あらゆる注文も受付まっしゃろけど、 この学校を利用して（全てボランティア活動）ご自分でやるべき仕事を押しつける っちゅう行為は横から見ていても腹立たしく思いまっせ。（笑）
ここは一番あっちゃんさんの努力する姿勢も見せて欲しいもんです。 ほな...（弥太郎）
横からですが。。。 私も最初は、（弥太郎）さんや（夏目雅子似）さんのマクロを感心してみているだけで 毎回更新時には、チェックを入れて勉強させて頂いておりましたが。。。 ここ最近は、お二人が便利屋さんのように見えて、個人的に悔しい思いをしておりました。 ここは、【学校】であって【依頼】をする場所ではないのでは？と、思います。 正直、私もここを利用させて頂いておりますし、先生方から過去にマクロ等を作って頂いた事はございます。 ただし、それは善意で行っていただいたものと感謝をしております。 少なくとも【注文】はしておりません。 それを紐解き、勉強し、応用するもの（自分のものにする）だと思います。
管理人さん、もしも不要だと思ったら削除をして下さい。 ただ余りにも、お二人の気持ちを考えると書かずにいられませんでした。。。 （通りすがりのもの） ↑名前をふせるのも、卑怯な気がして来たので・・・ （ぽこ）でした^^;
おっしゃる通り皆様はボランティです。
私が悪かったです。
申し訳ありませんでした。
皆様のご好意に甘えすぎていました。
今回も（いつも）「依頼」ではなく「ご好意」だったこと分かっているつもりでいたが。
自分の希望を叶えて下さり、弥太郎様、夏目似様には本当に感謝しております。
今回のコードは、「B2」とかいう具体的なことがなく、自分では不安だったので。
そうですよね。勉強は自分でしなければ身にならないですよね。
がんばります。色々考えてみます。
考えてみてだめだった時に、どこの部分がだめなのか是非教えて下さい。
ちょっと、時間がかかるとは思いますがガンバリます。
本当に、夏目似様数々のご無礼をお許し下さい。
弥太郎様、今回はご迷惑をおかけして申し訳ありませんでした。
また、自分の甘えをご指摘下さいましてありがとうございました。
今後とも、精進して頑張ります。
その節は、宜しくお願い致します。（あっちゃん）
まずは、夏目似様のコードで勉強させて頂いております。
前回もカキコさせて頂いた通り、各シートに１列５行挿入させ、作成しております。
番地の書いてある所は、全て変更し、Cellsの部分を変更しました。
Cells は、行と列かな？と思い数字をあてはめました。
ですが、マクロを実行させた場合、エラーが出て、デバックを見ると
'商品がなかったら、最下部に追加して転記
If MyRow = 0 Then
.Cells(MaxRow + 6, 2).Value = Wsh1.Cells(7, 3).Value
.Cells(MaxRow + 7, 2).Value = Wsh1.Cells(11, 2).Value
.Cells(MaxRow + 8, 2).Value = Wsh1.Cells(12, 2).Value
.Range(.Cells(MaxRow + 6, MySCol), .Cells(MaxRow + 6, MyECol)).Value = "'===="
.Range(.Cells(MaxRow + 6, MySCol), .Cells(MaxRow + 6, MyECol)).Font.ColorIndex = MyIndex
.Cells(MaxRow + 7, MySCol).Value = Wsh1.Cells(11, 3).Value
.Cells(MaxRow + 8, MySCol).Value = Wsh1.Cells(12, 3).Value
Else '商品があったらその行に転記
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Value = "'===="
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Font.ColorIndex = MyIndex
.Cells(MyRow + 6, MySCol).Value = Wsh1.Cells(11, 3).Value
.Cells(MyRow + 7, MySCol).Value = Wsh1.Cells(12, 3).Value
End If
の上から６行目
.Range(.Cells(MaxRow + 6, MySCol), .Cells(MaxRow + 6, MyECol)).Value = "'===="
に黄色のマーカーが。
この意味はどのようなものか教えて下さい。
宜しく お願い致します。
ちなみにsheet １ → sheet ２への項目転記はできました。（あっちゃん）
あっちゃんさん、こんばんは！
遅くまで頑張っていらしゃいますね。
仕事で必要なんでしょ？
今回のポイントはMaxRowは最小でも6にして
Match関数はいつも1からはじめることです。。
ちょっと、変更してみましたので、試してみてください。
（夏目雅子似）
Sub サンプル出荷()
Dim MySCol As Double, MyECol As Double, MyRow As Double
Dim MyMinDay As Double, MyMaxDay As Double, X As Double, Y As Double
Dim C As Range, MyItem As String, MyDayCount As Double
Dim MaxRow As Long, MyIndex As Long, MyAnser As Long
Dim Wsh1 As Worksheet, Wsh2 As Worksheet
Set Wsh1 = Worksheets("Sheet1")
Set Wsh2 = Worksheets("Sheet2")
MaxRow = Wsh2.Range("B65536").End(xlUp).Row
If MaxRow < 6 Then
MaxRow = 6
End If
MyItem = Wsh1.Cells(7, 3).Value
'入力のチェック
With Wsh1
For Each C In .Range("C7:C12")
If C.Value = "" Then
MsgBox C.Offset(, -1).Value & "が未入力です。。"
Exit Sub
End If
Next
'日付のチェック
If Not IsDate(.Cells(9, 3).Value) Or Not IsDate(.Cells(10, 3).Value) _
Or .Cells(9, 3).Value > .Cells(10, 3).Value Then
MsgBox "日付に誤りがあります。"
.Range(.Cells(9, 3), .Cells(10, 3)).ClearContents
Exit Sub
End If
End With
On Error Resume Next
With Wsh2
'Sheet2のレンタル管理期間日をチェック
MyMinDay = Application.WorksheetFunction.Min(.Range("C6", .Range("IV6")))
MyMaxDay = Application.WorksheetFunction.Max(.Range("C6", .Range("IV6")))
MyDayCount = Application.WorksheetFunction.CountA(.Range("C6", .Range("IV6")))
If MyMinDay <= 1 And MyMaxDay <= 1 Then
MsgBox "レンタル管理期間日が設定されていません。" & Chr(13) & Chr(13) & _
"Sheet2のC6からIV6の範囲にレンタル管理期間日を設定してください。", vbExclamation
Exit Sub
End If
If MyMaxDay - MyMinDay <> MyDayCount - 1 Then
MsgBox "レンタル管理期間日の設定が不適切です。" & Chr(13) & Chr(13) & _
"連続した日付を入力して下さい。", vbExclamation
Exit Sub
End If
If Wsh1.Cells(9, 3).Value < MyMinDay Or Wsh1.Cells(10, 3).Value > MyMaxDay Then
MsgBox "開始〜終了日が適応範囲外です。" & Chr(13) & Chr(13) & _
Format(MyMinDay, "yyyy/mm/dd") & "から" & Chr(13) & _
Format(MyMaxDay, "yyyy/mm/dd") & "までの期間を指定して下さい。", vbExclamation
Wsh1.Range(Cells(9, 3), Cells(10, 3)).ClearContents
Exit Sub
End If
'適応する行及び開始列終了行を取得
MyRow = Application.WorksheetFunction.Match( _
Wsh1.Cells(7, 3), .Range(.Cells(1, 2), .Cells(65536, 2).End(xlUp)), 0)
MySCol = Application.WorksheetFunction.Match( _
Wsh1.Cells(9, 3), .Range(.Cells(6, 1), .Cells(6, 256)), 0)
MyECol = Application.WorksheetFunction.Match( _
Wsh1.Cells(10, 3), .Range(.Cells(6, 1), .Cells(6, 256)), 0)
On Error GoTo 0
'商品があった場合に貸出し期間をチェック
If MyRow > 0 Then
'開始終了共に空白ではない場合
If .Cells(MyRow, MySCol).Value <> "" And .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
If .Cells(MyRow + 1, MyECol + 1).Value = "" And .Cells(MyRow + 2, MyECol + 1) = "" Then
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1) = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
End If
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 4 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
'開始日が空白じゃない場合
ElseIf .Cells(MyRow, MySCol).Value <> "" Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 4 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
X = X - 1
'終了日が空白じゃない場合
ElseIf .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1).Value = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
Y = Y + 1
'開始日と終了日の間が空白ではない場合
ElseIf Application.WorksheetFunction.CountA( _
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol))) > 0 Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
X = X - 1
Y = Y + 1
Else
GoTo MyLine
End If
MyAnser = MsgBox(MyItem & "は、貸し出し中または貸出し期間が設定されています。" _
& Chr(13) & Chr(13) & _
"開始日は " & Format(.Cells(6, Y).Value, "yyyy/mm/dd") & Chr(13) & _
"終了日は " & Format(.Cells(6, X).Value, "yyyy/mm/dd") & Chr(13) & _
"貸出し会社は " & .Cells(MyRow + 1, Y).Value & Chr(13) & _
"担当は " & .Cells(MyRow + 2, Y).Value & " です。" & Chr(13) & Chr(13) & _
"このデータを削除して新規に登録しますか？" & Chr(13) & Chr(13) & _
"キャンセルを押すとこのデータを削除して終了します。。", vbInformation + vbYesNoCancel)
Select Case MyAnser
Case vbYes
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Case vbNo
Exit Sub
Case vbCancel
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Wsh1.Range("C7:C12").ClearContents
Wsh1.Range("C7").Select
ActiveWorkbook.Save
Exit Sub
End Select
End If
MyLine:
'社内か社外かで色分け
If Wsh1.Cells(8, 3).Value = "社内にて" Then
MyIndex = 5
ElseIf Wsh1.Cells(8, 3).Value = "社外にて" Then
MyIndex = 3
End If
'商品がなかったら、最下部に追加して転記
If MyRow = 0 Then
.Cells(MaxRow + 1, 2).Value = Wsh1.Cells(7, 3).Value
.Cells(MaxRow + 2, 2).Value = Wsh1.Cells(11, 2).Value
.Cells(MaxRow + 3, 2).Value = Wsh1.Cells(12, 2).Value
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Value = "="
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Font.ColorIndex = MyIndex
.Cells(MaxRow + 2, MySCol).Value = Wsh1.Cells(11, 3).Value
.Cells(MaxRow + 3, MySCol).Value = Wsh1.Cells(12, 3).Value
Else '商品があったらその行に転記
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Value = "="
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Font.ColorIndex = MyIndex
.Cells(MyRow + 1, MySCol).Value = Wsh1.Cells(11, 3).Value
.Cells(MyRow + 2, MySCol).Value = Wsh1.Cells(12, 3).Value
End If
End With
Wsh1.Range("C7:c12").ClearContents
Wsh1.Range("C7").Select
ActiveWorkbook.Save
Set Wsh1 = Nothing
Set Wsh2 = Nothing
End Sub
VBAのすばらしさを教えて下さった上に（前回）、色々フォーマットを勝手に変更したのにかかわらず、コードを毎度毎度教えて下さって本当にありがとうございます。
お陰様で、望みが全て叶いました。
なんとお礼を申し上げたらよいのか判りません。
弥太郎様やぼこ様に、ご指摘を受け自分自身の甘さに恥ずかしい思いをしています。
人様のご好意に甘え過ぎずに頑張っていきます。
昨夜「精進して・・・」という言葉を書きましたが、夏目似様のご好意を受け更に強く思いました。
全てを人に聞く姿勢を改めます。反省しています。
夏目似様、あなたの寛大なお心に感謝します。
本当に本当にありがとうございました。
最後に、弥太郎様、色々ありがとうございました。
「学校」の先生のごとく、勉強だけではなく、考え違いをご指摘して頂き感謝しています。
（あっちゃん）
再び教えて頂きたいのですが〜。
あれから、色々考え試しているのですが、どうしても分からないので。
悩んでいますのは、シートの保護です。
事前にシートの保護をかけておいて、
VBAの始めに、シートの保護を解除し、VBAの最後の方でシートの保護を再びかけるという方法を試しています。
始めの方で
Dim MySCol As Double, MyECol As Double, MyRow As Double
Dim MyMinDay As Double, MyMaxDay As Double, X As Double, Y As Double
Dim C As Range, MyItem As String, MyDayCount As Double
Dim MaxRow As Long, MyIndex As Long, MyAnser As Long
Dim Wsh1 As Worksheet, Wsh2 As Worksheet
Set Wsh1 = Worksheets("Sheet 1”)
Set Wsh2 = Worksheets("Sheet 2")
MaxRow = Wsh2.Range("B65536").End(xlUp).Row
If MaxRow < 6 Then
MaxRow = 6
End If
ActiveSheet.Unprotect ←追加
Wsh1.Select ←追加
ActiveSheet.Unprotect ←追加
Wsh2.Select ←追加
MyItem = Wsh1.Cells(7, 3).Value
'入力のチェック
を入れ、
途中でマクロが止まってしまうので
'商品がなかったら、最下部に追加して転記
ActiveSheet.Unprotect ←追加
Wsh2.Select ←追加
If MyRow = 0 Then
を入れ
VBAの最後の方で
End With
Wsh1.Range("C7:c12").ClearContents
Wsh1.Range("C7").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True ←追加
Wsh1.Select ←追加
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True ←追加
Wsh2.Select ←追加
ActiveWorkbook.Save
Set Wsh1 = Nothing
Set Wsh2 = Nothing
End Sub
を入れてみました。
そして、マクロ実行させてみましたが、VBAの最後
Wsh1.Range("C7").Select
に、黄色のマーカーがつきます。
別のブックで似たようなフォーマットで、「マクロの記録」で書き込んでみましたが、
Wsh1.Range("C7:c12").ClearContents
Wsh1.Range("C7").Select
上記のコードのような感じになります。
ちなみに、Sheet １のC7:C12 のデータは消えています。
どこが悪いのでしょうか？
また、シート保護のパスワードを設定したいと思います（現在はパスワード設定なし）が無理なのでしょうか？
申し訳ありませんが、今一度ご教授頂けませんか？
宜しく お願い致します。（あっちゃん）
Wsh1.Range("C7").Select
の前にWsh1をSelectもしくはActivateでアクティブなシートにしていますか？
RangeオブジェクトをSelectするには対象のRangeオブジェクトの親、つまり
シートがアクティブになっていないとメソッド実行に失敗します。
シートがアクティブでもないのにいきなりセルは選択できない、
ということです。
ただし、この部分でSelectする必要はありますか？
Selectする必要さえなければ
Wsh1.Range("C7").Select この構文そのものを削除してかまわないと思います。
もう一つ
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
'前の状況から、Wsh2がアクティブになっていてWsh2の保護をしていると推測
Wsh1.Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
'Wsh1を選択した後Wsh1を保護
Wsh2.Select
'Wsh2を選択
という処理になっていますが、意図とあっていますか？
（結果的に両方保護するのだから同じことですが）
ActiveSheetをオブジェクトとして使用するときは
どのシートがアクティブか意識して使用してください。
下記のように直接オブジェクト指定してもOKです。
Wsh1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Wsh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
(KAMIYA)
＞Selectする必要さえなければ
＞Wsh1.Range("C7").Select この構文そのものを削除してかまわないと思います
ということでしたが、次のデータを入力するのにその位置にカーセルを持ってくるのが、本当は便利なのですが・・・。
実は、カキコする前に、この一文を削除してみたら、次のコードに黄色マーカーがついて、頭がパニックになってしまったのです。
今回も、やはり黄色のマーカーはつきましたが、KAMIYA様の言葉で安心し、無視してマクロ実行をしました。
出来ました。よかった。
シートの保護についても、スマートなので、KAMIYA様の方にしました。
Wsh1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Wsh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ありがとうございました。
また、是非教えて下さい。（あっちゃん）
色々、シートに条件付書式を入れ、セルの色や文字の色を変化させています。
A B C D E F G
1 会社名
2 部署
3 表題
4 説明文
5 曜日
6 日付 8/25 8/26 8/27 8/28 8/29
7 カゴ1 =================
8 貸出会社 でこぼこ社
9 担当者 一郎
10 ザル ===========
11 貸出会社 ○×社
12 担当者 二郎
というような状態です。
条件書式にて、今日（例えば8/27）に貸し出しているカゴ１（B7）とザル（B10）と記載されているセルに色をつけることがわかりません。
IF関数やMatchを入れてみたり、色々試していますが・・・。
申し訳ありませんが、どうか教えて下さい。（あっちゃん）
あっちゃんさん、こんばんは！ 単純に何かあったら？でいいんでしょ？ =COUNTA(G9:J9)>=1 範囲は適当に変えてください。 （夏目雅子似）
また、お助け下さいましてありがとうございます。
今日（Today()）という日付（変動しますよね毎日）の列にある「===」に反応させたいのです。
宜しく お願い致します。（あっちゃん）
D6の条件付書式に数式−=AND(D7<>"",D$6=TODAY())として書式を設定 他の該当するセルにコピーでしょうか。 （川野鮎太郎）
すみません、私の説明が悪いようで〜。（；^_^A
６行目の行は、日付が書き込んであります。
その日付、C6は8/25で、D6は8/26などと、毎日、毎日変動する列（Today()）の7行めと10行めの「===」に反応し、B7とB10の色が変わってほしいのです。
なので、そのカゴやザルの日付にずっ〜と「===」がついていれば、今日も明日も明後日もB7とB10各々色がつくようにしたいのです。
ご教授をお願い致します。 m（_ _）m （あっちゃん）
う〜ん(/-_-＼) いまいち理解できてないかもしれませんが・・・ B7の条件付書式に数式− =OFFSET(B7,0,MATCH(TODAY(),D6:K6,0)+1)="==="として書式を設定かな？ B10は=OFFSET(B10,0,MATCH(TODAY(),D6:K6,0)+1)="===" ※出来れば違う質問はスレッドを変えてもらったほうが、回答するのに楽かも(^_^A; （川野鮎太郎）
これでいいと思います。 =INDIRECT(ADDRESS(ROW(),MATCH(TODAY(),$A$6:$IU$6,0)))<>"" （夏目雅子似）
(・_・o)ン？"＝＝＝"って文字としての＝＝＝では無くて、なんでもってことですか？ （川野鮎太郎）
遅くまで頑張ってますね^^ 明日はお休みですか？ ＝＝＝とか ＝＝とか ＝とか ***とか *****とか に分けたつもりないから^^ （作者夏目雅子似）
改めまして
川野鮎太郎様 ありがとうございました。
このサンプル貸出のブックのことなので、ここに書いてしまってごめんなさい。
OFFSETという関数を教えて下さってありがとうございました。
自分の設定違いか？ よくわかりませんが、色が変化しませんでした。
きっと、自分の説明が不充分だからだと思います。
また、明日にでも考えてみます。すみませんでした。m（_ _）m
やってみましたら、ばっちりうまくいきました。
INDIRECT という関数も初めて見ました。
また、勉強不足が出てしまった。ごめんなさい。
夏目似様が作って下さったコードを上司の注文により、ちょびっとづつ
躓きながら、頑張って変更しています。
例えば、貸出会社名転記したあとに、最終期日を入れろ！とか
びくびくしながら、やっています。
少しづつ、少しづつですが、理解しようとする努力を続けています。
何とか頑張りますので、また教えて下さい。（あっちゃん）
また、教えて下さい。
昨夜、教えて頂いて、出来上がり提出したところ、
「担当者別の表もほしいな〜」言われてしまいました。
Sheet １のデータをsheet ３の最終行の各々の項目該当欄に転記し、担当者、機種、貸出 開 でソートをかけたい、と思います。
Sheet １ の 予約データ入力画面 （ ）セル番地を示しています
A B C
1 表題
2 会社名
3 部
4 課
5 係
6 項目
7 機種 カゴ
（B7） （C7）
8 形態 社外貸出
（B8） （C8）
9 期間 始 9/1
（B9） （C9）
10 至 9/2
（B10） （C10）
11 貸出会社 でこぼこ企画
（B11） （C11）
12 担当者 一郎
（B12） （C12）
sheet ３には、（ ）セル番地
A B C D E F G H
1表題１
2表題２
3表題３
4表題４
5表題５
6 担当者 機種 貸出会社 期間 開 〜 至 形態
（B6） （C6） （D6） （E6） （F6） （G6） （H6）
7 転記 →
8 転記 →
のように、フォーマットしました。
まず転記することからと思い、下記のようなコードを作ってみましたが、まったくダメです。
Sub テスト機貸出()
Dim MySCol As Double, MyECol As Double, MyRow As Double
Dim MyMinDay As Double, MyMaxDay As Double, X As Double, Y As Double
Dim C As Range, MyItem As String, MyDayCount As Double
Dim MaxRow As Long, MyIndex As Long, MyAnser As Long
Dim Wsh1 As Worksheet, Wsh2 As Worksheet
Set Wsh1 = Worksheets("sheet 1")
Set Wsh2 = Worksheets("sheet 2")
Set Wsh3 = Worksheets("sheet 3") ←追加
'商品がなかったら、最下部に追加して転記 ← この部分にsheet 3の最終行の下に各々の項目該当欄にデータを挿入しようとした
ActiveSheet.Unprotect
Wsh2.Select
If MyRow = 0 Then
.Cells(MaxRow + 1, 2).Value = Wsh1.Cells(7, 3).Value
.Cells(MaxRow + 2, 2).Value = Wsh1.Cells(11, 2).Value
.Cells(MaxRow + 3, 2).Value = Wsh1.Cells(12, 2).Value
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Value = "'===="
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Font.ColorIndex = MyIndex
.Cells(MaxRow + 2, MySCol).Value = Wsh1.Cells(11, 3).Value
.Cells(MaxRow + 3, MySCol).Value = Wsh1.Cells(12, 3).Value
Wsh3.Select ← 追加
If MyRow = 0 Then ← 追加
.Cells(MaxRow + 1, 2).Value = Wsh1.Cells(12, 3).Value ← 追加
.Cells(MaxRow + 1, 3).Value = Wsh1.Cells(7, 3).Value ← 追加
.Cells(MaxRow + 1, 4).Value = Wsh1.Cells(11, 3).Value ← 追加
.Cells(MaxRow + 1, 5).Value = Wsh1.Cells(9, 3).Value ← 追加
.Cells(MaxRow + 1, 7).Value = Wsh1.Cells(10, 3).Value ← 追加
.Cells(MaxRow + 1, 8).Value = Wsh1.Cells(8, 3).Value ← 追加
Else '商品があったらその行に転記
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Value = "'===="
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Font.ColorIndex = MyIndex
.Cells(MyRow + 1, MySCol).Value = Wsh1.Cells(11, 3).Value
.Cells(MyRow + 2, MySCol).Value = Wsh1.Cells(12, 3).Value
End If
End With ← ▲
動かない上に、マクロ実行中に▲の部分に、黄色のマーカーがついてしまったのです。
申し訳ありません。どのようにしたらよいのでしょうか？
宜しく お願い致します。（あっちゃん）
あっちゃんさん、こんばんは！ ぱっと見ただけだけど、、よくわかりません。(;^_^A アセアセ･･･ 今日は、これから出かけるのでまた明日にでもみてみます。 出来るかどうかわかりませんがぁ、、^^;ではでは、 （夏目雅子似）
何卒、ご教授をお願い致します！（あっちゃん）
大体、なんとなくわかりました。
↓こんな感じでいいかと思います。今回は、少し宿題形式にしていますので、
説明文を読みながら、メインコードに記述してください。
（夏目雅子似）
'Sheet3用の変数Max3Rowを用意する。
Dim Max3Row As Long
Set Wsh3 = Worksheets("Sheet3")
'Sheet3の最終行を取得する。B6に担当と入力されていると仮定
'B6が空白の場合はIf文で最低でも6にセットする。前回のIf文を参考にしてください。
Max3Row = Wsh3.Range("B65536").End(xlUp).Row '最低でも6が返ることを想定している。
With Wsh2
'ここに前回のメインコードが記述されている。
'この間は、かなり長いが注意して見ればすぐにわかる。
'この間に記述されている「.」の前には全て「Wsh2」がついていると考えればよい。
'つまり.Cells(Max3Row + 1, 2).Value = Wsh1.Cells(12, 3).Valueは
'Wsh2.Cells(Max3Row + 1, 2).Value = Wsh1.Cells(12, 3).Value
'と同じことになる。（Withとは・・・「With Me」って英語でよくいうでしょ？ずっと、ついてるんですね）
'だから、今回の様にSheet3に対応するコードを追加する場合はこの外に記述した方がわかりやすい。
End With
'↓が今回追加するメインコードとなる。
'全体的にSelectが多い様に思えるが、別にSelectしなくても転記は出来る。
With Wsh3 '←With Wsh3のはじまり
.Cells(Max3Row + 1, 2).Value = Wsh1.Cells(12, 3).Value '← 追加
.Cells(Max3Row + 1, 3).Value = Wsh1.Cells(7, 3).Value '← 追加
.Cells(Max3Row + 1, 4).Value = Wsh1.Cells(11, 3).Value '← 追加
.Cells(Max3Row + 1, 5).Value = Wsh1.Cells(9, 3).Value '← 追加
.Cells(Max3Row + 1, 7).Value = Wsh1.Cells(10, 3).Value '← 追加
.Cells(Max3Row + 1, 8).Value = Wsh1.Cells(8, 3).Value '← 追加
End With '←With Wsh3の終わり
'Wsh3を開放する。
Set Wsh3 = Nothing
昨夜は、書き込みありがとうございました。
頑張るぞ！と朝書き込みを印刷しましたが、月初に週末と来て、忙しくって腰を据えて考える時間がありませんでした。
今、会社から戻ってきましたので、これから頑張りま〜す！
また、分からなくなったら教えて下さい。
宜しく お願い致します。（あっちゃん）
む〜ん、（~_~;A
ちょっと（いっぱい）わかりません。
コートを、この辺かな？という所に貼り付けました。
動きません！
というか、勝手に終わってしまうのです。
今回は、どこかで、マクロが止まり、黄色のマーカーが付く訳ではありません。
よく見ると、
Sheet １ → 予約シート
の日付、入力洩れ等に関するメッセージはでます。
といいますか、sheet １の動きはよく、
sheet ２の画面に変わったな〜と思った瞬間、終わるのです。
？？？
つまり、今まで出来ていたsheet ２への転記も出来なくなりました。
どうしてでしょうか？
はる場所が違うのでしょうか？
Sub テスト機貸出()
Dim MySCol As Double, MyECol As Double, MyRow As Double
Dim MyMinDay As Double, MyMaxDay As Double, X As Double, Y As Double
Dim C As Range, MyItem As String, MyDayCount As Double
Dim MaxRow As Long, MyIndex As Long, MyAnser As Long
Dim Max3Row As Long ← 追加
Dim Wsh1 As Worksheet, Wsh2 As Worksheet, Wsh3 As Worksheet
Set Wsh1 = Worksheets("sheet1")
Set Wsh2 = Worksheets("sheet2")
Set Wsh3 = Worksheets("sheet3") ← 追加
MaxRow = Wsh2.Range("B65536").End(xlUp).Row
If MaxRow < 6 Then
MaxRow = 6
End If
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
MyItem = Wsh1.Cells(7, 3).Value
'入力のチェック
With Wsh1
For Each C In .Range("C7:C12")
If C.Value = "" Then
MsgBox C.Offset(, -1).Value & "が未入力です。。"
Exit Sub
End If
Next
'日付のチェック
If Not IsDate(.Cells(9, 3).Value) Or Not IsDate(.Cells(10, 3).Value) _
Or .Cells(9, 3).Value > .Cells(10, 3).Value Then
MsgBox "日付に誤りがあります。"
.Range(.Cells(9, 3), .Cells(10, 3)).ClearContents
Exit Sub
End If
End With
Max3Row = Wsh3.Range("B65536").End(xlUp).Row ← 追加
If Max3Row < 6 Then ← 追加
Max3Row = 6 ← 追加
On Error Resume Next
With Wsh2
'予約管理表の貸出管理期間日をチェック
MyMinDay = Application.WorksheetFunction.Min(.Range("C6", .Range("IV6")))
MyMaxDay = Application.WorksheetFunction.Max(.Range("C6", .Range("IV6")))
MyDayCount = Application.WorksheetFunction.CountA(.Range("C6", .Range("IV6")))
If MyMinDay <= 1 And MyMaxDay <= 1 Then
MsgBox "貸出管理期間日が設定されていません。" & Chr(13) & Chr(13) & _
"Sheet2のC6からIV6の範囲に貸出管理期間日を設定してください。", vbExclamation
Exit Sub
End If
If MyMaxDay - MyMinDay <> MyDayCount - 1 Then
MsgBox "貸出管理期間日の設定が不適切です。" & Chr(13) & Chr(13) & _
"連続した日付を入力して下さい。", vbExclamation
Exit Sub
End If
If Wsh1.Cells(9, 3).Value < MyMinDay Or Wsh1.Cells(10, 3).Value > MyMaxDay Then
MsgBox "開始〜終了日が適応範囲外です。" & Chr(13) & Chr(13) & _
Format(MyMinDay, "yyyy/mm/dd") & "から" & Chr(13) & _
Format(MyMaxDay, "yyyy/mm/dd") & "までの期間を指定して下さい。", vbExclamation
Wsh1.Range(Cells(9, 3), Cells(10, 3)).ClearContents
Exit Sub
End If
'適応する行及び開始列終了行を取得
MyRow = Application.WorksheetFunction.Match( _
Wsh1.Cells(7, 3), .Range(.Cells(1, 2), .Cells(65536, 2).End(xlUp)), 0)
MySCol = Application.WorksheetFunction.Match( _
Wsh1.Cells(9, 3), .Range(.Cells(6, 1), .Cells(6, 256)), 0)
MyECol = Application.WorksheetFunction.Match( _
Wsh1.Cells(10, 3), .Range(.Cells(6, 1), .Cells(6, 256)), 0)
On Error GoTo 0
'商品があった場合に貸出し期間をチェック
If MyRow > 0 Then
'開始終了共に空白ではない場合
If .Cells(MyRow, MySCol).Value <> "" And .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
If .Cells(MyRow + 1, MyECol + 1).Value = "" And .Cells(MyRow + 2, MyECol + 1) = "" Then
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1) = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
End If
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 4 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
'開始日が空白じゃない場合
ElseIf .Cells(MyRow, MySCol).Value <> "" Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 4 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
X = X - 1
'終了日が空白じゃない場合
ElseIf .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1).Value = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
Y = Y + 1
'開始日と終了日の間が空白ではない場合
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
ElseIf Application.WorksheetFunction.CountA( _
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol))) > 0 Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
X = X - 1
Y = Y + 1
Else
GoTo MyLine
End If
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
MyAnser = MsgBox(MyItem & "は、貸し出し中または貸出し期間が設定されています。" _
& Chr(13) & Chr(13) & _
"開始日は " & Format(.Cells(6, Y).Value, "yyyy/mm/dd") & Chr(13) & _
"終了日は " & Format(.Cells(6, X).Value, "yyyy/mm/dd") & Chr(13) & _
"貸出し会社は " & .Cells(MyRow + 1, Y).Value & Chr(13) & _
"担当は " & .Cells(MyRow + 2, Y).Value & " です。" & Chr(13) & Chr(13) & _
"この予約データを終了する場合は「はい」を、予約データを削除して改めて予約を登録をする場合は「いいえ」を押して下さい。" & Chr(13) & Chr(13) & _
"現在登録されている予約を取り消す場合は「キャンセル」を押して下さい。", vbInformation + vbYesNoCancel)
Select Case MyAnser
Case vbYes
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Case vbNo
Exit Sub
Case vbCancel
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Wsh1.Range("C7:C12").ClearContents
Wsh1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Wsh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
Exit Sub
End Select
End If
MyLine:
'社内か社外かで色分け
If Wsh1.Cells(8, 3).Value = "社内" Then
MyIndex = 5
ElseIf Wsh1.Cells(8, 3).Value = "社外貸出" Then
MyIndex = 3
End If
'商品がなかったら、最下部に追加して転記
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
If MyRow = 0 Then
.Cells(MaxRow + 1, 2).Value = Wsh1.Cells(7, 3).Value
.Cells(MaxRow + 2, 2).Value = Wsh1.Cells(11, 2).Value
.Cells(MaxRow + 3, 2).Value = Wsh1.Cells(12, 2).Value
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Value = "'===="
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Font.ColorIndex = MyIndex
.Cells(MaxRow + 2, MySCol).Value = Wsh1.Cells(11, 3) & " 〜 " & Format(Wsh1.Cells(10, 3).Value, "mm / dd")
.Cells(MaxRow + 3, MySCol).Value = Wsh1.Cells(12, 3).Value
Else '商品があったらその行に転記
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Value = "'===="
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Font.ColorIndex = MyIndex
.Cells(MyRow + 1, MySCol).Value = Wsh1.Cells(11, 3) & " 〜 " & Format(Wsh1.Cells(10, 3).Value, "mm / dd")
.Cells(MyRow + 2, MySCol).Value = Wsh1.Cells(12, 3).Value
End If
End With
With Wsh3 '
.Cells(Max3Row + 1, 2).Value = Wsh1.Cells(12, 3).Value ' ← 追加
.Cells(Max3Row + 1, 3).Value = Wsh1.Cells(7, 3).Value ' ← 追加
.Cells(Max3Row + 1, 4).Value = Wsh1.Cells(11, 3).Value ' ← 追加
.Cells(Max3Row + 1, 5).Value = Wsh1.Cells(9, 3).Value ' ← 追加
.Cells(Max3Row + 1, 7).Value = Wsh1.Cells(10, 3).Value ' ← 追加
.Cells(Max3Row + 1, 8).Value = Wsh1.Cells(8, 3).Value ' ← 追加
End With ' ← 追加
Wsh1.Range("C7:c12").ClearContents
Wsh1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Wsh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
Set Wsh1 = Nothing
Set Wsh2 = Nothing
Set Wsh3 = Nothing
End If ← 追加
End Sub
どうしてでしょうか？
宜しく お願い致します。（あっちゃん）
こんばんは。夏目雅子似さんではありませんし、マクロも長すぎてよくわかりませんが…
とりあえずF8キーで1行ずつ実行することができるので、どう動いているのか確認してみてはどうでしょうか。 ステップ実行中、マウスポインタを変数に近づけると中身を確認することができます。
もし知ってたらごめんなさい。無視してください。 (wizik)
wizikさんフォローありがとうございます。
あっちゃんさん、全部みたわけじゃないですよ。
とりあえず動いたみたいですけど、、、
あっちゃんさんのご意思を尊重しております。^^
（夏目雅子似）
Sub テスト機貸出()
Dim MySCol As Double, MyECol As Double, MyRow As Double
Dim MyMinDay As Double, MyMaxDay As Double, X As Double, Y As Double
Dim C As Range, MyItem As String, MyDayCount As Double
Dim MaxRow As Long, MyIndex As Long, MyAnser As Long
Dim Max3Row As Long '← 追加
Dim Wsh1 As Worksheet, Wsh2 As Worksheet, Wsh3 As Worksheet
Set Wsh1 = Worksheets("sheet1")
Set Wsh2 = Worksheets("sheet2")
Set Wsh3 = Worksheets("sheet3") '← 追加
MaxRow = Wsh2.Range("B65536").End(xlUp).Row
If MaxRow < 6 Then
MaxRow = 6
End If
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
MyItem = Wsh1.Cells(7, 3).Value '入力のチェック
With Wsh1
For Each C In .Range("C7:C12")
If C.Value = "" Then
MsgBox C.Offset(, -1).Value & "が未入力です。。"
Exit Sub
End If
Next
'日付のチェック
If Not IsDate(.Cells(9, 3).Value) Or Not IsDate(.Cells(10, 3).Value) _
Or .Cells(9, 3).Value > .Cells(10, 3).Value Then
MsgBox "日付に誤りがあります。"
.Range(.Cells(9, 3), .Cells(10, 3)).ClearContents
Exit Sub
End If
End With
Max3Row = Wsh3.Range("B65536").End(xlUp).Row '← 追加
If Max3Row < 6 Then '← 追加
Max3Row = 6 '← 追加
End If '← 追加
On Error Resume Next
With Wsh2
'予約管理表の貸出管理期間日をチェック
MyMinDay = Application.WorksheetFunction.Min(.Range("C6", .Range("IV6")))
MyMaxDay = Application.WorksheetFunction.Max(.Range("C6", .Range("IV6")))
MyDayCount = Application.WorksheetFunction.CountA(.Range("C6", .Range("IV6")))
If MyMinDay <= 1 And MyMaxDay <= 1 Then
MsgBox "貸出管理期間日が設定されていません。" & Chr(13) & Chr(13) & _
"Sheet2のC6からIV6の範囲に貸出管理期間日を設定してください。", vbExclamation
Exit Sub
End If
If MyMaxDay - MyMinDay <> MyDayCount - 1 Then
MsgBox "貸出管理期間日の設定が不適切です。" & Chr(13) & Chr(13) & _
"連続した日付を入力して下さい。", vbExclamation
Exit Sub
End If
If Wsh1.Cells(9, 3).Value < MyMinDay Or Wsh1.Cells(10, 3).Value > MyMaxDay Then
MsgBox "開始〜終了日が適応範囲外です。" & Chr(13) & Chr(13) & _
Format(MyMinDay, "yyyy/mm/dd") & "から" & Chr(13) & _
Format(MyMaxDay, "yyyy/mm/dd") & "までの期間を指定して下さい。", vbExclamation
Wsh1.Range(Cells(9, 3), Cells(10, 3)).ClearContents
Exit Sub
End If
'適応する行及び開始列終了行を取得
MyRow = Application.WorksheetFunction.Match( _
Wsh1.Cells(7, 3), .Range(.Cells(1, 2), .Cells(65536, 2).End(xlUp)), 0)
MySCol = Application.WorksheetFunction.Match( _
Wsh1.Cells(9, 3), .Range(.Cells(6, 1), .Cells(6, 256)), 0)
MyECol = Application.WorksheetFunction.Match( _
Wsh1.Cells(10, 3), .Range(.Cells(6, 1), .Cells(6, 256)), 0)
On Error GoTo 0
'商品があった場合に貸出し期間をチェック
If MyRow > 0 Then
'開始終了共に空白ではない場合
If .Cells(MyRow, MySCol).Value <> "" And .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
If .Cells(MyRow + 1, MyECol + 1).Value = "" And .Cells(MyRow + 2, MyECol + 1) = "" Then
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1) = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
End If
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 4 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
'開始日が空白じゃない場合
ElseIf .Cells(MyRow, MySCol).Value <> "" Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
If .Cells(MyRow + 1, MySCol).Value = "" And .Cells(MyRow + 2, MySCol) = "" Then
Do While .Cells(MyRow, Y - 1).Value <> ""
If .Cells(MyRow + 1, Y - 1).Value = "" And .Cells(MyRow + 2, Y - 1) = "" Then
Y = Y - 1
If Y < 4 Then Exit Do
Else
Y = Y - 1
Exit Do
End If
Loop
End If
X = X - 1
'終了日が空白じゃない場合
ElseIf .Cells(MyRow, MyECol).Value <> "" Then
X = MyECol
Do While .Cells(MyRow, X + 1).Value <> ""
If .Cells(MyRow + 1, X + 1).Value = "" And .Cells(MyRow + 2, X + 1).Value = "" Then
X = X + 1
If X > 255 Then Exit Do
Else
Exit Do
End If
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
Y = Y + 1
'開始日と終了日の間が空白ではない場合
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
ElseIf Application.WorksheetFunction.CountA( _
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol))) > 0 Then
X = MyECol
Do Until .Cells(MyRow, X - 1).Value <> ""
X = X - 1
If X < MySCol Then Exit Do
Loop
Y = MySCol
Do Until .Cells(MyRow, Y + 1).Value <> ""
Y = Y + 1
If Y > MyECol Then Exit Do
Loop
X = X - 1
Y = Y + 1
Else
GoTo MyLine
End If
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
MyAnser = MsgBox(MyItem & "は、貸し出し中または貸出し期間が設定されています。" _
& Chr(13) & Chr(13) & _
"開始日は " & Format(.Cells(6, Y).Value, "yyyy/mm/dd") & Chr(13) & _
"終了日は " & Format(.Cells(6, X).Value, "yyyy/mm/dd") & Chr(13) & _
"貸出し会社は " & .Cells(MyRow + 1, Y).Value & Chr(13) & _
"担当は " & .Cells(MyRow + 2, Y).Value & " です。" & Chr(13) & Chr(13) & _
"この予約データを終了する場合は「はい」を、予約データを削除して改めて予約を登録をする場合は「いいえ」を押して下さい。" & Chr(13) & Chr(13) & _
"現在登録されている予約を取り消す場合は「キャンセル」を押して下さい。", vbInformation + vbYesNoCancel)
Select Case MyAnser
Case vbYes
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Case vbNo
Exit Sub
Case vbCancel
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents
Wsh1.Range("C7:C12").ClearContents
Wsh1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Wsh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
Exit Sub
End Select
End If
MyLine:
'社内か社外かで色分け
If Wsh1.Cells(8, 3).Value = "社内" Then
MyIndex = 5
ElseIf Wsh1.Cells(8, 3).Value = "社外貸出" Then
MyIndex = 3
End If
'商品がなかったら、最下部に追加して転記
ActiveSheet.Unprotect
Wsh1.Select
ActiveSheet.Unprotect
Wsh2.Select
If MyRow = 0 Then
.Cells(MaxRow + 1, 2).Value = Wsh1.Cells(7, 3).Value
.Cells(MaxRow + 2, 2).Value = Wsh1.Cells(11, 2).Value
.Cells(MaxRow + 3, 2).Value = Wsh1.Cells(12, 2).Value
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Value = "'===="
.Range(.Cells(MaxRow + 1, MySCol), .Cells(MaxRow + 1, MyECol)).Font.ColorIndex = MyIndex
.Cells(MaxRow + 2, MySCol).Value = Wsh1.Cells(11, 3) & " 〜 " & Format(Wsh1.Cells(10, 3).Value, "mm / dd")
.Cells(MaxRow + 3, MySCol).Value = Wsh1.Cells(12, 3).Value
Else '商品があったらその行に転記
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Value = "'===="
.Range(.Cells(MyRow, MySCol), .Cells(MyRow, MyECol)).Font.ColorIndex = MyIndex
.Cells(MyRow + 1, MySCol).Value = Wsh1.Cells(11, 3) & " 〜 " & Format(Wsh1.Cells(10, 3).Value, "mm / dd")
.Cells(MyRow + 2, MySCol).Value = Wsh1.Cells(12, 3).Value
End If
End With
With Wsh3 '
.Cells(Max3Row + 1, 2).Value = Wsh1.Cells(12, 3).Value ' ← 追加
.Cells(Max3Row + 1, 3).Value = Wsh1.Cells(7, 3).Value ' ← 追加
.Cells(Max3Row + 1, 4).Value = Wsh1.Cells(11, 3).Value ' ← 追加
.Cells(Max3Row + 1, 5).Value = Wsh1.Cells(9, 3).Value ' ← 追加
.Cells(Max3Row + 1, 7).Value = Wsh1.Cells(10, 3).Value ' ← 追加
.Cells(Max3Row + 1, 8).Value = Wsh1.Cells(8, 3).Value ' ← 追加
End With ' ← 追加
Wsh1.Range("C7:c12").ClearContents
Wsh1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Wsh2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
Set Wsh1 = Nothing
Set Wsh2 = Nothing
Set Wsh3 = Nothing
End Sub
Wizik様ありがとうございました。
F8キーの事は、知っていたのですが、よく分からなかったのです。( ;^_^ A
夏目似様、ありがとうございました。
動きました。
「 ’ 」が最後になかったのですね。
「 ‘ 」には、どのような意味が込められているのでしょうか？
始め、マクロ実行した時、「End Sub に対する End If がない」と出て、深く考えず、最後の方にEnd If を入れてしまいました。これも違ったようですね。
F1キーで意味を調べながら、進めようとはしていますが、書いてある内容が40％ぐらいしかわからず（用語とか）、自分の無知に情けなさを感じています。
書いてある内容を少しでも理解したいと思い、図書館や本屋に出かけて行きますがありません。「田舎」過ぎて( >_< )
町まで出かけて行くのも、時間がかかり( ;^_^ A
ところで、うっかりしていたのですが、
予約キャンセルで予約が取り消された場合 と
sheet ３が完成（予約、または、予約取り消しのどちらかした時）時
ソートを、担当者（B列） → 機種（C列） → 期間 始（E列） を昇順にしたと思います。
そこで、
With Wsh3 '
.Cells(Max3Row + 1, 2).Value = Wsh1.Cells(12, 3).Value '
.Cells(Max3Row + 1, 3).Value = Wsh1.Cells(7, 3).Value '
.Cells(Max3Row + 1, 4).Value = Wsh1.Cells(11, 3).Value '
.Cells(Max3Row + 1, 5).Value = Wsh1.Cells(9, 3).Value '
.Cells(Max3Row + 1, 7).Value = Wsh1.Cells(10, 3).Value '
.Cells(Max3Row + 1, 8).Value = Wsh1.Cells(8, 3).Value '
Select Case MyAnser
Case vbCancel
.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents '
.Range("b7").CurrentRegion.Sort Key1:=Range("B7"), _
Order1:=xlAscending, Key2:=Range("C7") _
, Order2:=xlAscending, Key3:=Range("e7") _
, Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With '
としましたが、だめでした。( >_< )
どこのへんが、動かない原因かお教え願えないでしょうか？
宜しく お願い致します。（あっちゃん）
よくみてませんが、キャンセルを押した時にシート3のデータもクリアにしてソートするってこと？ もしも、そうだとしたら、それは少々無理があるんじゃないのかなぁ。。 だって、キャンセルの対象になっているのは、シート2にあるデータであって シート3とは全然関係ないでしょ？ >.Range(.Cells(MyRow, Y), .Cells(MyRow + 2, X)).ClearContents ' のMyRowやYやXはシート2の行と列を表しているんだから、シート3とは関係ないもんね(^^;; ヒヤアセ もしもそれをしようとすると、シート3はシート3で別に検索しないといけないんじゃないのかなぁ。。。。 しかもそれを特定するのは難しいと思いますよ。キャンセルは別の方法を考えた方がいいんじゃないのかなぁ。。。 途中から追加したり目的を変更しようとするとどうしても無理が生じるから構成から練り直す 必要があるみたいですね(;^_^A アセアセ それから、wizikさんも仰てる様に、F8キーを使ってもう少しコードの中身を理解された方がいいですね。 ExcelとVBEを両方立ち上げて（最大にしないで大きさを調整する）F8キーを押すと コードを１つ１つ実際の画面をみながら実行できるのね。そうすると、変数の意味や 動きが理解出来てメンテも出来る様になると思います。でないと、いつまでたっても 理解できないと思いますよ。わかって頂けたかな？(;^_^A あせあせ･･･ 追伸！ソートだけしたいのであれば、前に作ったコードの様にソートの部分だけを自動記録 してそれをシートのコードに張るのはどうでしょう？ 実際にはキャンセルされたデータも残ってるからシート2の内容とは違いますけどね。^^; とりあえず一案ということで、、ではでは。。(^_^)/~~~~ （夏目雅子似）
色々ありがとうございました。
ソートをかける方法は、自分の頭の中で、標準モジュール内に入れなければという思いがありました。
おっしゃる通り、sheet ３にはるという方法をとり、アクティブになる度にソートがかかるということにしました。
何故か、ソートが思うところからはかかってくれなかったのですが、何回かやっているうちにうまくいきました。（ctrl ＋ ＊）で確認しながら。
予約取消の方法は、止めることになりました。（そのまま予約を取ってきたという証で）
お騒がわせして申し訳有りませんでした。
色々アドバイスがあったので、なんとか出来ました。
本当にありがとうございました。（あっちゃん）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.