Results of 1 - 1 of about 103 for フォーマット 自動 印刷 (0.009 sec.)
フォーマット (1423), 自動 (14517), 印刷 (5709)
- [[20050414215944]]
- #score: 8137
- @digest: 2d88581eb90d5a977de0afe45d4d394d
- @id: 13447
- @mdate: 2005-04-19T02:37:48Z
- @size: 43879
- @type: text/plain
- #keywords: tennki (112894), 者順 (61183), mytbl (31733), しボ (31693), ーゲ (24623), ゲッ (21461), 付順 (20276), mydate (19612), protect (16871), 業者 (16788), 記先 (13684), commandbars (13227), autofiltermode (10706), xlascending (9517), soulman (9192), 保護 (8758), 行分 (8740), お試 (8449), 無効 (8354), entirerow (7009), autofilter (6816), 転記 (6623), 者名 (6358), screenupdating (5931), application (5369), レビ (4748), 解除 (4657), 印刷 (4596), トフ (4438), ボタ (4065), ビュ (4047), オー (3956)
- 『納期管理表-今日までのデータ印刷実行』（あっちゃん）
こんばんは。また、教えて下さい。 今、納期管理表を作っています。 下記の通りA1に項目、A2〜D100までデーターが入っています。 A B C D 1 品 名 業者名 型 式 納期 2 バナナ イ会社 3本SET 4/15 3 みかん ロ会社 2個SET 4/13 〜〜〜 100 りんご ハ会社 5個SET 4/10 毎日、まだ納品されていない品物のリストを作成する為、D列（納期日付）をソートし、数日前〜今日までの分を、範囲指定し印刷をしています。 ちなみに、100行のデータの中には、納期日が未入力のものも、ずっと先の日にちのものもあります。 マクロやVBAなどを利用し、ショートカットキーで、この印刷が実行される方法を教えて頂けないでしょうか? ---- オートフィルタで空白セルを抽出し印刷を記録して見ては如何でしょう? (ケン） ------ 申し訳ありません。 説明が悪いようで。 D列の納期日は、受注した時に決まるのです。 たまたま、近日中の日付しかここでは、例としてあげていませんでしたが、1日〜半年先までぐらいの納期が入力してあります。 その数、多い時で、500件ぐらいです。 数々あるデータの中で、納期が今日より以前のものだけを印刷したいのです。 宜しく、お願いいたします。 （あっちゃん） ---- オートフィルタのオプションで抽出すれば、記録出来ませんか? （ケン） ---- 申し訳ありません。 オートフィルタのオプションで、 抽出条件 TODAY() 以下 としましたが、ダメでした。 抽出条件 TODAY() と等しい ともしてみましたが、やはりダメでした。 どのように、設定すればよいのでしょうか? （あっちゃん） ------- あっちゃんさん!おはようございます。 頑張ってますね(^.^) そんな時は記録するといいですよ。 ちょっと記録すると↓の様になって Option Explicit Sub Macro1() Selection.AutoFilter Selection.AutoFilter Field:=4, Criteria1:="<=2005/4/15", Operator:=xlAnd End Sub これをちょろっと加工すると Sub てすと() Dim Wh1 As Worksheet, Wh2 As Worksheet Dim MyTbl As Range Dim MyDate As String Set Wh1 = Sheets("Sheet1") Set Wh2 = Sheets("Sheet2") With Wh1 Set MyTbl = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 4) MyDate = Format(Date, "yyyy/mm/dd") .AutoFilterMode = False MyTbl.AutoFilter Field:=4, Criteria1:="<=" & MyDate With .AutoFilter.Range If .Columns(1).SpecialCells(12).Cells.Count > 1 Then Wh2.Cells.ClearContents .Copy Destination:=Wh2.Range("A1") ' Wh2.PrintOut Else MsgBox "ありません" End If End With .AutoFilterMode = False End With Set Wh1 = Nothing Set Wh2 = Nothing Set MyTbl = Nothing End Sub こうなりましたぁv(=∩_∩=)v http://ryusendo.no-ip.com/cgi-bin/upload/src/up0279.xls （SoulMan） ---- おはようございます。SoulManさんフォロー有難うございます。 ＞これをちょろっと加工すると ちょろっとじゃない気が・・・(^^ 記録したのを加工する、大事ですよね。 （ケン） ------ 特別サービス!! サンプルをアップしておきました。 右クリックして 対象ファイルを保存してお試しください。 （SoulMan） ------ こんばんは。SoulManさま、またまたありがとうございます。 [[20040625010324]]-出荷管理表で、教えて頂いたVBAを使って、別部署で新しい納期管理表を作っています。 この表は、以前同様A列でリスト入力した言葉（納品状態が、「未」「済」）と同じシート名「未」「済」の所に、データが移行するというものです。お蔭様で、この部分に関してはデータスタート行が変更しているにもかかわらず、うまく動いてくれています。（感激!） 今回、印刷したい表の対象範囲は、A100（項目）〜K500（データ行が増える可能性大）です。 また、L、M列にもデータが入っていますが、印刷はしたくありません。 その表の中（データ数395個）から、「未」シートのみのJ列に入っている日付が、今日より以前のものだけを印刷したいという希望です。 SoulManさまのup0279のファイル、Sheet1の該当するシートをSheet2に転記するという方法ですね。 説明不足で申し訳ありませんでした。以前作っていただいた「未」「済」転記ということを考えますと・・・。 私なりに考えて、VBAを変更しましたが、根本のSheet転記という部分でVBAが止まっている様子? 一瞬ですがオートフィルタの表示が青い▼も希望のJ列にでます。 しかし、印刷プレビューになりません。 A B C D E F G H I J K 100 納品状態 業者 フリガナ 製番 機種 オーダー番号 品目コード 品名 発注日 納期日 備考 101 未 イ会社 イガイシャ A10 ○△ 123 A1B1C1 みかん 05/03/31 05/04/17 なし 102 未 ロ会社 ロカイシャ A13 ○× 128 A1D1C1 バナナ 05/03/31 05/09/15 なし 103 未 ハ会社 ハカイシャ A20 ×△ 125 A1B2C1 みかん 05/04/11 未定 なし 〜〜〜 200 未 イ会社 イカイシャ A15 ○△ 127 A1B1C1 みかん 05/04/09 05/04/16 なし Sub 印刷() ' ' 印刷 Macro ' マクロ記録日 : 2005/4/15 ユーザー名 : user ' Dim Wh1 As Worksheet Dim MyTbl As Range Dim MyDate As String Set Wh1 = Sheets("未") With Wh1 Set MyTbl = .Range("A101", .Range("A65536").End(xlUp)).Resize(, 10) MyDate = Format(Date, "yy/mm/dd") .AutoFilterMode = False MyTbl.AutoFilter Field:=10, Criteria1:="<=" & MyDate With .AutoFilter.Range If .Columns(1).SpecialCells(12).Cells.Count > 1 Then Else MsgBox "ありません" End If End With .AutoFilterMode = False End With Set Wh1 = Nothing Set MyTbl = Nothing End Sub また、表の一部に関数が使ってある所がある為、シートの保護がかけたいのです。 最初と最後に保護、保護解除を入れたのですが、止まってしまいます。 どうも転記をする時にひっかかるようです。 どこに、入れたらよいのでしょうか? Private Sub Worksheet_Change(ByVal Target As Range) ActiveSheet.Unprotect ←▲ Sheets("済").Select ←▲「済」シートには"未"と。 ActiveSheet.Unprotect ←▲ Sheets("未").Select ←▲「済」シートには"未"と。 Dim tennki_saki As String Dim Wks As Worksheet Dim MyRow As Long Dim C As Integer, i As Integer 'シートを保護するのは↓のコードでいいと思います。 Me.Protect , , , , , True 'ユーザーの操作のみを保護するものですから、マクロの操作は保護されません。 'ターゲットの列がA列以外か行が101行より小さかったら無効 If Target.Column <> 1 Or Target.Row < 101 Then Exit Sub 'ターゲットの複数選択を不可にする。 If Target.Count > 1 Then Exit Sub 'ターゲットのDeleteを無効 If Target.Value = "" Then Exit Sub '転記先はターゲットの値 tennki_saki = Target.Value '転記先が自分だったら無効 If Me.Name = tennki_saki Then Exit Sub 'イベントを無効にする。 Application.EnableEvents = False 'ワークシートをループ For Each Wks In Worksheets '変数iを初期化 i = 0 '転記先のシート名とターゲットの値が同じだったら（つまり、転記先のシートがあったら） If Wks.Name = tennki_saki Then '転記先シートのB列を基準に最終行+1を取得 MyRow = Sheets(tennki_saki).Range("B65536").End(xlUp).Row + 1 With Me '変数Cを列数分ループ For C = 1 To .Range("A6").End(xlToRight).Column Sheets(tennki_saki).Cells(MyRow, C).Value = Cells(Target.Row, C).Value Next C '転記が完了したら、ターゲットを削除 Target.EntireRow.Delete Shift:=xlUp ←◎ End With '転記が完了したらループから抜ける Exit For End If '変数iに1を代入してシートの有無を確認 i = 1 Next '変数iが0じゃなかったら If i <> 0 Then MsgBox "転記先のシート 「" & tennki_saki & "」 は、ありません。" & Chr(13) & _ "転記先のシート名が正しいかもう一度確認して下さい。", vbCritical, "Excelの学校 VBA" End If '移行した行分を補う。 Rows("498:498").Select Selection.Copy Rows("497:497").Select Selection.Insert Shift:=xlDown Application.CutCopyMode = False Range("A101").Select 'イベントを有効にする。 Application.EnableEvents = True '保護をかける。 Sheets("済").Select ←▲「済」シートには"未"と。 ActiveSheet.Protect ←▲ Sheets("未").Select ←▲「済」シートには"未"と。 ActiveSheet.Protect ←▲ Application.ScreenUpdating = True End Sub ------ こんばんは!遅くなってすみません。 ところで今回はコードの中に説明を書いていますから 説明ごと標準モジュールに貼り付けてください。 Option Explicit '基本はマクロの記録です。 'それからブレークポイントを覚えた方がいいです。 '簡単に説明しますから、これを機に覚えてください。 Sub Macro1() '←この灰色のところをマウスでクリックしてください。 Selection.AutoFilter Field:=10, Criteria1:="<=2004/12/20", Operator:=xlAnd 'クリック出来るところと出来ないところがありますが●が付いたらOKです。 'マクロを実行すると●の行でマクロが停止します。これがブレイクポイントです。 '後はF8でひとつひとつステップ実行するんです。 'その時VBE画面を最大表示にしないで小さく表示して実際の動きを確認しながら実行するのが 'ポイントです。ExcelのシートとVBE画面を二つ表示しながら実行するんです。 'ExcelのシートはVBE画面の左上のExcelのマークをクリックすれば表示されます。 End Sub Sub 印刷() Dim Wh1 As Worksheet Dim MyTbl As Range Dim MyDate As String Set Wh1 = Sheets("未") '********************************************* '抽出する日付を設定します。 MyDate = Format(Date, "yyyy/mm/dd") '↓日付はこんな書き方も出来ると思います。例は今日の一日前です。 'MyDate = Format(DateSerial(Year(Date), Month(Date), Day(Date) - 1), "yyyy/mm/dd") '********************************************** With Wh1 Set MyTbl = .Range("A101", .Range("A65536").End(xlUp)).Resize(, 10) '**************************************************** '印刷に関する設定をします。 '実際の設定を記録して応用されたらいいでしょう。 With .PageSetup .PrintArea = MyTbl.Address .PrintTitleRows = "$101:$101" End With '****************************************************** 'オートフィルタを一旦解除します。 .AutoFilterMode = False 'オートフィルタを設定します。 MyTbl.AutoFilter Field:=10, Criteria1:="<=" & MyDate '↓これが元になった記録のコードです。 'Selection.AutoFilter Field:=10, Criteria1:="<=2004/12/20", Operator:=xlAnd 'F8で実行しながらMyDateにマウスを近づけると変数の中身が見えますから '是非みてください。 With .AutoFilter.Range 'データが抽出されたかを判断します。 If .Columns(1).SpecialCells(12).Cells.Count > 1 Then .PrintPreview 'プレビューです。.PrintOutとお好みで使い分けてください。 ' .PrintOut ←プレビューなしで印刷します。 Else MsgBox "ありません" End If End With 'オートフィルタモードを解除します。 .AutoFilterMode = False End With '変数を開放します。 Set Wh1 = Nothing Set MyTbl = Nothing End Sub シートの保護については Me.Protect , , , , , True ↑ こんなコードを上のコードの中に追加していますので参考にしてください。 （SoulMan） ------ こんにちは。昨夜のうちに、レス頂いていたのですね。ありがとうございました。自分なりに考えてはみたものの、頭が痛くなり寝てしまいました。m( _ _ )m 朝起きて、見てSoulManさまに感謝しながら、私の希望のページ設定に変更させて頂きました。 Dim Wh1 As Worksheet Dim MyTbl As Range Dim MyDate As String Set Wh1 = Sheets("未") '抽出する日付を設定します。 MyDate = Format(DateSerial(Year(Date), Month(Date), Day(Date) - 0), "yyyy/mm/dd") With Wh1 Set MyTbl = .Range("A101", .Range("A65536").End(xlUp)).Resize(, 11) '印刷に関する設定をします。 With .PageSetup .PrintArea = MyTbl.Address .PrintTitleRows = "$1:$100" End With 'オートフィルタを一旦解除します .AutoFilterMode = False 'オートフィルタを設定します。 MyTbl.AutoFilter Field:=10, Criteria1:="<=" & MyDate With .AutoFilter.Range 'データが抽出されたかを判断します。 If .Columns(1).SpecialCells(12).Cells.Count > 1 Then .PrintPreview 'プレビューです。 Else MsgBox "ありません" End If End With 'オートフィルタモードを解除します。 .AutoFilterMode = False End With '変数を開放します。 Set Wh1 = Nothing Set MyTbl = Nothing End Sub マクロを起動させますと、確かに今日より以前の期日のものだけが、印刷プレビューで出てきます。（すばらしい!） しかし、今日の期日のデータが例えば5つしかない（1ページで収まる）のに、印刷プレビューが12ページ出てきます。2〜11ページは罫線のみ。 何が影響しているのでしょうか? また、保護についてですが、私以上にパソに不慣れな人が使うので、データ入力時には、不必要で重要な関数が入っている部分がある為、シートに保護をかけたいのです。従いまして、VBA起動時には、まず、最初に保護の解除を入れ、最後に保護をかけるようにしたいのです。 始めは、例えば「未」シートには、上記（▲部分）のように、組んでみたのですが、◎の所で止まってしまいます。何がいけないのでしょうか? また、「済」から返品等により「未」になる場合があります。このため、"未"、"済"などと限定した言葉ではなく、Tenki_Sakiなどの言葉にし、どのシートにも使えて、また、今後シートが増えた時にも困らないようにしたいのですが・・・。 よろしく、お願い致します。 （あっちゃん） ----- また、UP0279で、ご使用なさっていらっしゃる「お試しボタン」なるものは、どのように作成するのでしょうか? （あっちゃん） --------- スレッドが長くなるのでここに貼り付けます。 シートモジュールに Option Explicit Private Sub Worksheet_Activate() 'UserInterfaceOnlyをTrueにしてユーザーの操作のみに保護を掛けます。 Me.Protect , , , , True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Wks As Worksheet Dim tennki_saki As String Dim MyRow As Long, C As Long Dim MyFlag As Boolean 'UserInterfaceOnlyをTrueにしてユーザーの操作のみに保護を掛けます。 Me.Protect , , , , True 'ターゲットの列がA列以外か行が101行より小さかったら無効 If Target.Column <> 1 Or Target.Row < 101 Then Exit Sub 'ターゲットの複数選択を不可にする。 If Target.Count > 1 Then Exit Sub 'ターゲットのDeleteを無効 If Target.Value = "" Then Exit Sub '転記先はターゲットの値 tennki_saki = Target.Value '転記先が自分だったら無効 If Me.Name = tennki_saki Then Exit Sub '画面の更新を停止 Application.ScreenUpdating = False 'イベントを無効にする。 Application.EnableEvents = False 'ワークシートをループ For Each Wks In Worksheets '転記先のシート名とターゲットの値が同じだったら（つまり、転記先のシートがあったら） If Wks.Name = tennki_saki Then 'シートの有無を判定 MyFlag = True '念の為、転記先のUserInterfaceOnlyをTrueにします。 Wks.Protect , , , , True '転記先シートのB列を基準に最終行をOffset(1)で取得 MyRow = Sheets(tennki_saki).Range("B65536").End(xlUp).Offset(1).Row With Me '変数Cを列数分ループ For C = 1 To .Range("A6").End(xlToRight).Column Sheets(tennki_saki).Cells(MyRow, C).Value = Cells(Target.Row, C).Value Next C '転記が完了したら、ターゲットを削除 Target.EntireRow.Delete Shift:=xlUp End With '転記が完了したらループから抜ける Exit For End If Next 'MyFlagがFalseだったら（シートがなかったら） If MyFlag = False Then MsgBox "転記先のシート 「" & tennki_saki & "」 は、ありません。" & Chr(13) & _ "転記先のシート名が正しいかもう一度確認して下さい。", vbCritical, "Excelの学校 VBA" Else '削除した行分を補う。 With Me .Range("A498").EntireRow.Copy Destination:=.Range("A497") .Range("A497").Insert Shift:=xlDown .Range("A101").Select .Protect , , , , True 'イベントを無効にしている間に行の挿入を行う為 '保護が無効になってしまいますのでここで再度保護を掛けます。 End With End If 'イベントを有効にする。 Application.EnableEvents = True '画面の更新を解除 Application.ScreenUpdating = True End Sub ThisWorkBookモジュールに Option Explicit Private Sub Workbook_Open() Dim Wh As Worksheet 'お試しボタンを作ります。 MyMenuBar '画面の更新を停止 Application.ScreenUpdating = False 'ワークシートを保護します。 For Each Wh In Worksheets Wh.Protect , , , , True Next '画面の更新を解除します。 Application.ScreenUpdating = True End Sub '終了前にMyComを開放します。 Private Sub Workbook_BeforeClose(CANCEL As Boolean) MySet End Sub 標準モジュールに Option Explicit Dim MyClass As New Class1 Sub MyUnlockMsg() Set MyClass.MyCom = Application.CommandBars("Protection").Controls(1) End Sub Sub Auto_Open() MyUnlockMsg End Sub Sub MySet() Set MyClass.MyCom = Nothing End Sub Sub てすと() Dim Wh1 As Worksheet Dim MyTbl As Range Dim MyDate As String Set Wh1 = Sheets("未") '抽出する日付を設定します。 MyDate = Format(Date, "yyyy/mm/dd") '画面の更新を停止 Application.ScreenUpdating = False With Wh1 'UserInterfaceOnlyをTrueにしてユーザーの操作のみに保護を掛けます。 .Protect , , , , True '保護下でのオートフィルタを有効にします。 .EnableAutoFilter = True 'データ範囲をMyTblに取得します。 Set MyTbl = .Range("A101", .Range("A65536").End(xlUp)).Resize(, 11) '印刷に関する設定をします。 With .PageSetup .PrintArea = MyTbl.Address .PrintTitleRows = "$1:$100" '←こうじゃないんですか? End With 'オートフィルタを一旦解除します .AutoFilterMode = False 'オートフィルタを設定します。 MyTbl.AutoFilter Field:=10, Criteria1:="<=" & MyDate With .AutoFilter.Range 'データが抽出されたかを判断します。 If .Columns(1).SpecialCells(12).Cells.Count > 1 Then .PrintPreview 'プレビューです。 Else MsgBox "ありません" End If End With 'オートフィルタモードを解除します。 .AutoFilterMode = False End With Application.ScreenUpdating = True '変数を開放します。 Set Wh1 = Nothing Set MyTbl = Nothing End Sub 'お試しボタンを作るコードです。 Sub MyMenuBar() Dim MyBar As CommandBar Dim MyCtrl As CommandBarButton On Error Resume Next CommandBars("お試しボタン").Delete On Error GoTo 0 'TemporaryをTrueにして終了と同時に自動的に削除します。 Set MyBar = Application.CommandBars.Add("お試しボタン", , , True) 'MyCtrlをMyBarに追加します。 Set MyCtrl = MyBar.Controls.Add(msoControlButton) With MyCtrl .Caption = "お試しボタン" .OnAction = "てすと" '実行するマクロ名です。 .FaceId = 2892 .Width = 80 End With 'お試しボタンを表示します。 Application.CommandBars("お試しボタン").Visible = True End Sub クラスモジュールに Option Explicit Public WithEvents MyCom As CommandBarButton Private Sub MyCom_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) If ActiveSheet.ProtectContents = False Then MsgBox "シートの保護は自動的に設定されます。" & Chr(13) & _ "個々に操作する必要はありません。。" CancelDefault = True End If End Sub http://ryusendo.no-ip.com/cgi-bin/upload/src/up0283.xls （SoulMan） ------ お出かけ前にありがとうございました。 1.シート解除について シートは、データ入力時には保護の状態にしていたい、のです。 つまり、マクロのスタート時には、まず、保護解除からさせたいのです。 Unprotectからはじまるのではないのでしょうか?（私の認識不足?） また、保護解除を転記元、転記先両方解除してマクロを進めているつもりなのに、何故◎の所で止まるのでしょうか? 2.印刷に関しましては 私が、作成した表の中には、フリガナ（C列）を表示させるための関数（VLOOKUP）がフォーマット済の部分500行分入力されています。 これが原因なのかな?と思い削除してみたら、SoulManさまのおっしゃる通り今日のデータのみ印刷プレビューに出てきます。 しかし、業者には並んでほしい順があり、それを含んだキーワードを入れてフリガナにしています。 このフリガナの関数を無視して、納期日のみを判断基準にすることはできないのでしょうか? 3.印刷ページ設定について ご指摘を頂戴致しました行のタイトルですが、会社名、注意事項文等が入っていて、A1〜A100までを行のタイトルとしました。 また、中間の3〜96行めまでは、「表示しない」にさせています。m( _ _ )m 4.「お試しボタン」作成方法について 分かりました。すみませんでした。 上記3つについて、また教えていただけませんでしょうか? また、私のフォーマット通りUp0282を作成して頂きありがとうございました。 やはり、2.の項目が原因なんだな〜と再確認しました。 お時間を、いつも頂き申し訳ありません。 何卒、よろしくお願い致します。 （あっちゃん） -------------- お試しボタンを見たということはサンプルはDLしたんでしょ? サンプルup0282.xlsは止まらないでしょ? すみません。悪いところがわかりました。 スレッドが長くなるので上のコードで修正しています。 色々なモジュールを使っていますので注意して貼り付けてください。 帰ったらサンプルもアップします。 >フォーマット済の部分500行分入力されています これがよくわかりませんが、VLOOKUPで抽出するのなら別シートの出来ませんか? （SoulMan） ----- はい、DLさせて頂きました。 本当だ!ごめんなさい。止まらない! 勘違いをしていました。 ちょっと、出かけてきますので、ゆっくりと夜見せて下さい。 申し訳ありません。 更新をしようとする度、SoulManさまが編集して下さっているようですね。 帰ったら、バカな頭で考えますので、ちょっとお待ちを。m( _ _ )m （あっちゃん） ---------------- こんばんは! 一応上のコードを修正しておきました。 非表示にしておけば100行のタイトルもいいみたいだけど、どうかな? >フォーマット済の部分500行分入力されています 私にはレイアウトが見えませんので、なんともいえませんが、 印刷範囲を指定しているので問題ないと思うのですがぁ?? どうでしょうか? （SoulMan） -------- こんばんは! SoulManさまは、何事も早いですね、 私が、3時間もかかって、編集にかかっているうちに、またレスを頂戴しまして。 ごめんなさい。 修正して頂いたものを、今一度見せて頂きます。 とりあえず、3時間かかって書いたものを登録させて下さい。m( _ _ )m 色々なモジュールに、いっぱいのVBAありがとうございました。 1.お蔭様で上記の1.に関しましては、大大満足です。 こんな事できるのですね。 ただ、残念な事に、「マクロの記録」を利用して、「業者順」と「日付順」というプログラム（?）があったのが、作動しなくなりました。 いつも、いつも後から希望で申し訳ないのですが・・・。 シートモジュールには 「未」シートの転記VBAの後ろに → 日付順 シートがセレクトされたら、日付→業者名順にソートがかかるように 「済」シートの転記VBAの後ろに → 日付順 シートがセレクトされたら、日付→業者名順にソートがかかるように Option Explicit Private Sub Worksheet_Activate() 'シートを保護するのは↓のコードでいいと思います。 Me.Protect , , , , True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim tennki_saki As String Dim Wks As Worksheet Dim MyRow As Long Dim C As Integer, i As Integer 'シートを保護するのは↓のコードでいいと思います。 Me.Protect , , , , True 'ユーザーの操作のみを保護するものですから、マクロの操作は保護されません。 'ターゲットの列がA列以外か行が101行より小さかったら無効 If Target.Column <> 1 Or Target.Row < 101 Then Exit Sub 'ターゲットの複数選択を不可にする。 If Target.Count > 1 Then Exit Sub 'ターゲットのDeleteを無効 If Target.Value = "" Then Exit Sub '転記先はターゲットの値 tennki_saki = Target.Value '転記先が自分だったら無効 If Me.Name = tennki_saki Then Exit Sub 'イベントを無効にする。 Application.ScreenUpdating = False Application.EnableEvents = False 'ワークシートをループ For Each Wks In Worksheets '変数iを初期化 i = 0 '転記先のシート名とターゲットの値が同じだったら（つまり、転記先のシートがあったら） If Wks.Name = tennki_saki Then '転記先シートのB列を基準に最終行+1を取得 Wks.Protect , , , , True MyRow = Sheets(tennki_saki).Range("B65536").End(xlUp).Row + 1 With Me '変数Cを列数分ループ For C = 1 To .Range("A6").End(xlToRight).Column Sheets(tennki_saki).Cells(MyRow, C).Value = Cells(Target.Row, C).Value Next C '転記が完了したら、ターゲットを削除 Target.EntireRow.Delete Shift:=xlUp '←◎ End With '転記が完了したらループから抜ける Exit For End If '変数iに1を代入してシートの有無を確認 i = 1 Next '変数iが0じゃなかったら If i <> 0 Then MsgBox "転記先のシート 「" & tennki_saki & "」 は、ありません。" & Chr(13) & _ "転記先のシート名が正しいかもう一度確認して下さい。", vbCritical, "Excelの学校 VBA" Else '移行した行分を補う。 With Me .Range("A498").EntireRow.Copy Destination:=.Range("A497") .Range("A497").Insert Shift:=xlDown .Range("A101").Select .Protect , , , , True 'イベントを無効にしている間に行を挿入しているので '保護が無効になっていますのでここで再度保護を掛けます。 End With End If 'イベントを有効にする。 Application.EnableEvents = True Application.ScreenUpdating = True End Sub Private Sub Worksheet_Activate1() 'シートを保護するのは↓のコードでいいと思います。 Me.Protect , , , , True End Sub Private Sub Worksheet_Activate2() '日付順になおす。 Application.ScreenUpdating = False Range("A100").CurrentRegion.Sort Key1:=Range("J101"), Order1:=xlAscending, Key2:=Range( _ "C101"), Order2:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin .Protect , , , , True End Sub 標準モジュールには 日付順（日付、業者名順）（データ入力時、閲覧のみの時に使用するように） 業者順（業者名、日付順）（データ入力時、閲覧のみの時に使用するように） でも、みんな効かなくなっちゃったのです。 UP0279で超カッコよかったので、オブジェクトにマクロ登録したボタン2種類（日付順、業者順）を作り、よろこんでいたのですが・・・。（T_T） どうしたらよいのでしょうか? また、印刷時には、日付順にソートをかけた後で、オートフィルタをかけたいのです。 Sub MyUnlockMsg() Set MyClass.MyCom = Application.CommandBars("Protection").Controls(1) End Sub Sub Auto_Open() MyUnlockMsg End Sub Sub MySet() Set MyClass.MyCom = Nothing End Sub Sub 印刷() ←SoulManさまは「てすと」命名 Dim Wh1 As Worksheet Dim MyTbl As Range Dim MyDate As String Set Wh1 = Sheets("未") '日付、業者順にソートをかける。 Range("A100").CurrentRegion.Sort Key1:=Range("J101"), Order1:=xlAscending, Key2:=Range( _ "C101"), Order2:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin '抽出する日付を設定します。 MyDate = Format(Date, "yyyy/mm/dd") With Wh1 .Protect , , , , True .EnableAutoFilter = True Set MyTbl = .Range("A101", .Range("A65536").End(xlUp)).Resize(, 11) '印刷に関する設定をします。 With .PageSetup .PrintArea = MyTbl.Address .PrintTitleRows = "$1:$100" End With 'オートフィルタを一旦解除します .AutoFilterMode = False 'オートフィルタを設定します。 MyTbl.AutoFilter Field:=10, Criteria1:="<=" & MyDate With .AutoFilter.Range 'データが抽出されたかを判断します。 If .Columns(1).SpecialCells(12).Cells.Count > 1 Then .PrintPreview 'プレビューです。 Else MsgBox "ありません" End If End With 'オートフィルタモードを解除します。 .AutoFilterMode = False End With '変数を開放します。 Set Wh1 = Nothing Set MyTbl = Nothing End Sub Sub 日付順() ' ' Macro1 Macro ' マクロ記録日 : 2005/4/12 ユーザー名 : user ' ' Application.ScreenUpdating = False Range("A100").CurrentRegion.Sort Key1:=Range("J101"), Order1:=xlAscending, Key2:=Range( _ "C101"), Order2:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin Application.ScreenUpdating = True End Sub Sub 業者順() ' ' 業者順 Macro ' マクロ記録日 : 2005/4/12 ユーザー名 : user ' ' Application.ScreenUpdating = False Range("A100").CurrentRegion.Sort Key1:=Range("C101"), Order1:=xlAscending, Key2:=Range( _ "J101"), Order2:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin Application.ScreenUpdating = True End Sub 2.500行のフォーマットの件ですが、B列の業者名（例B101）がリスト入力により入力されたら、同シート内の表（M5〜N98）（M列は業者名、N列はキーワード入りフリガナ）により、C列のフリガナ（例C101）が入力されるという関数が入っています。 例 C101のセルには =IF(ISERROR(VLOOKUP(B101,$M$5:$N$98,2,FALSE)),"",VLOOKUP(B103,$M$5:$N$98,2,FALSE)) 何とか、解決策はあるのでしょうか? 色々、申し訳ありません。 よろしく、お願い致します。 （あっちゃん） --------------- 困りましたね。長くなって私もよくわかりません。 一応これでいいと思いますがどうでしょうか? それから >500行のフォーマットの件ですが、 ''なぜ?データベースの先頭100行にこの様なのもがあるのか理解できません。'' もともとフィールド（見出し）は一行で項目が特定できれば十分です。 ↓この式も =IF(ISERROR(VLOOKUP(B101,$M$5:$N$98,2,FALSE)),"",VLOOKUP(B103,$M$5:$N$98,2,FALSE)) $M$5:$N$98この範囲を別シートに作ればいいだけではないのですか? ''基本的な仕様の変更を考えられた方がいいように思います。'' どうでしょうか? ここからコードの修正記事になります。 Activateの1とか2とかは出来ません。名前を勝手に変えてはいけません。 Private Sub Worksheet_Activate() 'シートを保護するのは↓のコードでいいと思います。 Me.Protect , , , , True '日付順になおす。 Application.ScreenUpdating = False Range("A100").CurrentRegion.Sort _ Key1:=Range("J101"), Order1:=xlAscending, _ Key2:=Range("C101"), Order2:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin Application.ScreenUpdating = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) の方はサンプルで問題ないと思いますので割愛させていただきます。 標準モジュールはこれでいいと思いますがどうでしょうか? Option Explicit '標準モジュールには '日付順（日付、業者名順）（データ入力時、閲覧のみの時に使用するように） '業者順（業者名、日付順）（データ入力時、閲覧のみの時に使用するように） 'でも、みんな効かなくなっちゃったのです。 'UP0279で超カッコよかったので、オブジェクトにマクロ登録したボタン2種類（日付順、業者順）を作り、 'よろこんでいたのですが・・・。（T_T） 'どうしたらよいのでしょうか? 'また、印刷時には、日付順にソートをかけた後で、オートフィルタをかけたいのです。 Sub MyUnlockMsg() Set MyClass.MyCom = Application.CommandBars("Protection").Controls(1) End Sub Sub Auto_Open() MyUnlockMsg End Sub Sub MySet() Set MyClass.MyCom = Nothing End Sub Sub 印刷() '←SoulManさまは「てすと」命名 Dim Wh1 As Worksheet Dim MyTbl As Range Dim MyDate As String Set Wh1 = Sheets("未") '抽出する日付を設定します。 MyDate = Format(Date, "yyyy/mm/dd") With Wh1 .Protect , , , , True .EnableAutoFilter = True '日付、業者順にソートをかける。 .Range("A100").CurrentRegion.Sort _ Key1:=.Range("J101"), Order1:=xlAscending, _ Key2:=.Range("C101"), Order2:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin Set MyTbl = .Range("A101", .Range("A65536").End(xlUp)).Resize(, 11) '印刷に関する設定をします。 With .PageSetup .PrintArea = MyTbl.Address .PrintTitleRows = "$1:$100" End With 'オートフィルタを一旦解除します .AutoFilterMode = False 'オートフィルタを設定します。 MyTbl.AutoFilter Field:=10, Criteria1:="<=" & MyDate With .AutoFilter.Range 'データが抽出されたかを判断します。 If .Columns(1).SpecialCells(12).Cells.Count > 1 Then .PrintPreview 'プレビューです。 Else MsgBox "ありません" End If End With 'オートフィルタモードを解除します。 .AutoFilterMode = False End With '変数を開放します。 Set Wh1 = Nothing Set MyTbl = Nothing End Sub Sub 日付順() ' ' Macro1 Macro ' マクロ記録日 : 2005/4/12 ユーザー名 : user ' ' Application.ScreenUpdating = False Range("A100").CurrentRegion.Sort _ Key1:=Range("J101"), Order1:=xlAscending, _ Key2:=Range("C101"), Order2:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin Application.ScreenUpdating = True End Sub Sub 業者順() ' ' 業者順 Macro ' マクロ記録日 : 2005/4/12 ユーザー名 : user ' ' Application.ScreenUpdating = False Range("A100").CurrentRegion.Sort _ Key1:=Range("C101"), Order1:=xlAscending, _ Key2:=Range("J101"), Order2:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin Application.ScreenUpdating = True End Sub （SoulMan） ------ ありがとうございました。 先頭100行に、業者名、フリガナをもっていったのは、 転記したりする時に障害となるのでは? メンテの時に、データ行の削除などしても誤って消さないか? という点から、可能性がない先頭100行に、業者名、フリガナをもっていったのです。 印刷は印刷範囲指定で、1ページ〜○ページと入力するようにします。 印刷プレビューが出ているので、○ページと入力しやすいです。v(‾‾)v お蔭様で、私の希望通りに、転記、印刷、日付順、業者順など、快適に動いてくれています。m( _ _ )m こんなに天気のよい日に、貴重なお時間頂戴しまして、本当にありがとうございました。 保護の方法に、びっくりしました。 本当に、ありがとう。 （あっちゃん） ---------- なんとか?無理やり?解決したみたいでよかったです(^^; >基本的な・・・ くれぐれも気分を悪くなさらないでくださいましね。 あっちゃんさんの事情もあるでしょうからね。 また何かあったらいつでも聞いてください。 私のわかる範囲でお答えしますので・・ ではでは、v(=∩_∩=)v （SoulMan） ----- こんにちは。（書き始めた頃は、おはようございます!だったのに） SoulManさま、私は気分を悪くするどころか、感謝の気持ちでいっぱいです。 申し訳ないのですが、もうちょっと、お付き合いいただけませんか? よろしくお願い致します。 1.「500行」という量は、普通ならデータ3ヶ月が入力できる量です。 万一、大量に注文が来た時、または作業者がA列の「未」「済」の変更を怠った時でもよいように（まず無いことですが・・・）という考えから、 500行分をフォーマットしておこうと思ったのです。 その為、 '移行した行分を補う。←▲▲ With Me .Range("A498").EntireRow.Copy Destination:=.Range("A497") .Range("A497").Insert Shift:=xlDown .Range("A101").Select .Protect , , , , True のA498をコピーし、コピーしたものを挿入するということにしたかったのです。 ですが、VBAなら データの最終行をコピー（関数やセルの色の変化をさせる条件付き書式が設定されているから最終行のコピー）し、 その1行前に挿入させることができますよね。 但し、データの最終行をセルのロックをかけておいて削除されないなど安全策を考えなければなりませんが。 それって、上のコード▲▲を下記のように変更しただけではダメなんですね。 '移行した行分を補う。 With Me .Range("B65536").End(xlUp).Copy Destination:=.Range("B65536").End(xlUp).ROW - 1 .Range("B65536").End(xlUp).ROW - 1.Insert Shift:=xlDown .Range("A101").Select .Protect , , , , True 悲しい事に挿入部分 .Range("B65536").End(xlUp).ROW - 1.Insert Shift:=xlDown が赤くなり、先に進めなくなりました。(T_T) どのようにしたらよいのでしょうか? 2.また、500行のフォーマットを止め、最小限の行のみにしたとして、 新規データ入力時に行が必要になった時の為に、オブジェクトのボタンを2つ作り、 例えば、最終行をコピーしその最終行の前に1行分挿入とか5行挿入とか選択できるようにしたいと思います。 お手数ですが、是非教えて下さい。 1.と2.をすれば、印刷プレビューが、今日以前のデータ + 1 程度で終わるはずですよね。 3.それから・・・ エクセルのこのファイルを閉じ、再び開けると 標準モジュールに Sub MyUnlockMsg() Set MyClass.MyCom = Application.CommandBars("Protection").Controls(1) '←黄色 End Sub になります。SoulManさまのUP0283はならないのに・・・。 また、閉じようとすると Sub MySet() Set MyClass.MyCom = Nothing '←黄色 End Sub これは、ThisWorksbookモジュールのお試しボタン部分●●を消したから?でしょうか? Option Explicit Private Sub Workbook_Open() Dim Wh As Worksheet 'お試しボタンを作ります。←●● MyMenuBar ←●● '画面の更新を停止 Application.ScreenUpdating = False 'ワークシートを保護します。 For Each Wh In Worksheets Wh.Protect , , , , True Next '画面の更新を解除します。 Application.ScreenUpdating = True End Sub '終了前にMyComを開放します。 Private Sub Workbook_BeforeClose(CANCEL As Boolean) MySet End Sub すみません。もう1度教えて下さい。 （あっちゃん） ------- どうもそこがおかしいと思っていましたが、以下でどうでしょうか? '削除した行分を補う。 With Me With .Range("A65536").End(xlUp) .EntireRow.Copy .EntireRow.Insert Shift:=xlDown Application.CutCopyMode = False End With .Range("A101").Select .Protect , , , , True 'イベントを無効にしている間に行の挿入を行う為 '保護が無効になってしまいますのでここで再度保護を掛けます。 End With それからお試しボタンにかかわる部分は必要なければ消しちゃってください。 あっごめんなさい。 >最終行をコピーしその最終行の前に1行分挿入とか5行挿入とか >選択できるようにしたいと思います。 これを見逃していました。 これで最終行をコピー出来ますが、5行挿入の場合は5回実行してください。(^^; というのは冗談の様な本気の様な??? 選択出来る様にするのは簡単だけど、あまり意味ない様な?? どうでしょうか? Option Explicit Sub てすと() With ActiveSheet.Range("A65536").End(xlUp) .EntireRow.Copy .EntireRow.Insert Shift:=xlDown Application.CutCopyMode = False End With End Sub こうしたら、五行挿入です。 Sub 五行挿入() With ActiveSheet.Range("A65536").End(xlUp).Offset(-5).Resize(6) .EntireRow.Copy .EntireRow.Insert Shift:=xlDown Application.CutCopyMode = False End With End Sub （SoulMan） ----- SoulManさまって、本当に早いですね。 「お試しボタンは・・・」で、一度SoulManさまのレスを見せて頂き、 削除した行分を補う コードをコピーさせて頂き貼り付けてみて、色々試させていただいておりました。 500行フォーマットをやめた上で、新しいコードにした時、 A列を「未」→「済」に変更した時はいいのですが、「済」→「未」の時、罫線がなくなる!などの弊害が出てきて、苦慮しておりました。(^^A 今回、罫線のみの空行を設ける事にして解決しました。 （行には条件付き書式にて「VLOOKUPのデータが無い事」ことを注意を促す） そして、五行挿入も自分なりに考えてみましたが・・・。 Sub 五行挿入() With ActiveSheet.Range("A65536").End(xlUp) .EntireRow.Copy .EntireRow.Insert Shift:=x5Down '←● 1 → 5 に変更しただけ Application.CutCopyMode = False End With End Sub ●だけでは、ダメなんですね。（マクロ名の五も5ではダメなんですね） SoulManさまの Sub 五行挿入() With ActiveSheet.Range("A65536").End(xlUp).Offset(-5).Resize(6) .EntireRow.Copy .EntireRow.Insert Shift:=xlDown Application.CutCopyMode = False End With End Sub は、最終行から上に5行コピーし挿入するのですよね。 勝手言って申し訳ないのですが、最終行1行を5行分挿入したいのです。 それから・・・ エクセルのこのファイルを閉じ、再び開けると 実行エラー「424」 オブジェクトが必要です と出ます。 標準モジュールに Sub MyUnlockMsg() Set MyClass.MyCom = Application.CommandBars("Protection").Controls(1) '←黄色 End Sub になります。SoulManさまのUP0283はならないのに・・・。 また、閉じようとすると Sub MySet() Set MyClass.MyCom = Nothing '←黄色 End Sub どうしたらいいのでしょうか? （あっちゃん） -------- 5回繰り返してください。 Sub 五行挿入() Dim i As Long For i = 1 To 5 With ActiveSheet.Range("A65536").End(xlUp) .EntireRow.Copy .EntireRow.Insert Shift:=xlDown Application.CutCopyMode = False End With Next i End Sub 黄色くなったところは消してください。 （SoulMan） ------------ こんばんは!進んでますか? お試しボタンのコードだけをまとめてみましたので参考にしてください。 お試しボタンのニューバージョンです。色々登録出来る様にしてみました。 いらない時はThisWorkBookの 「お試しボタンをつくるコードです」 だけを削除すればいいです。そうすれば作りませんから・・・ ThisWorkBookのモジュールに Option Explicit Private Sub Workbook_Open() 'Bookを開く時に↓が実行されてお試しボタンを作ります。 '不要になったら消してください。 お試しボタンをつくるコードです End Sub 標準モジュールに Option Explicit Sub お試しボタンをつくるコードです() Dim MyBar As CommandBar Dim MyCtrl As CommandBarComboBox On Error Resume Next CommandBars("お試しボタン").Delete On Error GoTo 0 Set MyBar = Application.CommandBars.Add("お試しボタン", , , True) Set MyCtrl = MyBar.Controls.Add(msoControlDropdown) With MyCtrl .AddItem "てすと1", 1 'どんどん追加してください。 .AddItem "てすと2", 2 'どんどん追加してください。 .AddItem "てすと3", 3 'どんどん追加してください。 .ListIndex = 1 .Caption = "お試しボタン" .OnAction = "お試しボタン" .Width = 80 End With Application.CommandBars("お試しボタン").Visible = True End Sub Private Sub お試しボタン() Select Case Application.CommandBars("お試しボタン").Controls(1).ListIndex Case 1 MsgBox "てすと1を選択しました" 'ここに実行したいマクロ名を書きます。 Case 2 MsgBox "てすと2を選択しました" 'ここに実行したいマクロ名を書きます。 Case 3 MsgBox "てすと3を選択しました" 'ここに実行したいマクロ名を書きます。 End Select Application.CommandBars("お試しボタン").Controls(1).ListIndex = 1 End Sub http://ryusendo.no-ip.com/cgi-bin/upload/src/up0285.xls （SoulMan） ------ SoulManさま、やっぱり早い! 黄色の所は、消してということですが、全部（日付順も業者順も印刷も）動かなくなってしまいました。 今一度、ゆっくりとUP00283と見比べてみましたら、標準モジュールの1行めが抜けていました。 全部コピーして張り付けたつもりだったのに・・・。(^^A 落ちかなくては! 全部チェックして、もれがないようにして、マクロを実行せてたら今度はOKでした。 大変、お騒がせいたしました。 お試しボタンですか〜! UP0285を拝見させて頂きました。 ▽で選べるなんてすご〜い!! 是非、今度使わせて頂きます。 上のように、応用が効くように書いて下さると大変うれしいです。 大事な数日、数十時間、私のためにありがとうございました。 私の希望全部叶った最高のVBAをありがとうございました。 （あっちゃん） ------------- あっちゃんさん、すみません。お詫びと訂正です。 オートフィルタの抽出条件の部分なのですが、 日付に対してはやはりシリアル値で対応するのが正当なので 文字列型として宣言している ↓これを Dim MyDate As String ↓長整数型のLongに変更してください。 Dim MyDate As Long 更に 文字列に変換している↓を MyDate = Format(Date, "yyyy/mm/dd") ↓とか MyDate = DateSerial(Year(Date), Month(Date), Day(Date)) ただ単に ↓ MyDate = Date とかに変更してください。 実は、私も以前から気になっていたのですが、他の方の誤解の元になってもいけませんので、 訂正させてください。ではでは、大変失礼しました。m(__)m （SoulMan）... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/200504/20050414215944.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97059 documents and 608315 words.
訪問者：