[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『商品出荷管理表』（あっちゃん）
今、商品管理表を作成しています。
Sheet 1に受注、Sheet 2に完成、Sheet 3に出荷 というデータがあります。
フォーマットは、すべてのSheet に共通です。
まず、今、手作業として
１．Sheet 1（受注）にてデータを打ち込む。
２．数日後、商品が完成したらA列の状況を変更する。受注 → 完成
データは100行近くになり、またランダムに変更になる。
例えば、今は、3行目と5行目が、受注 → 完成 で、4行目はそのままとか。
３．A3受注と入力してあるデータを完成と直し、その行を切り取り、Sheet 2（完成）に”切り取ったデータ挿入”で、データを入れる。
４．挿入後のデータは、B列でソートをかけて、番号順にする。
５．Sheet 2（完成）の中のデータで、出荷したもののA列の状況を完成から出荷に直し、その行を切り取り、Sheet 3（出荷）に”切り取ったデータ挿入”で、データを入れる。
６．挿入後のデータは、B列でソートをかけて、番号順にする。
なんとか、現在手で行なっている作業を、瞬時に手軽に出来ないものかと思います。
また、A列の状況データーの修正数は日によって変更します。
その上、、各Sheet に入っているデーター100行近くあります。
よろしくお願いいたします。
A B C D E F
1 状況 製造番号 納入先 品名 部品手配 etc
2 受注 ア123 アイ商事 ザル 7/10 ･･･
3 受注 ア456 ウエ商事 カゴ 8/10 ･･･
4 受注 ア789 カキ商事 ザル 10/10 ･･･
5 受注 ア125 サシ商事 ザル 7/10 ･･･
excel2000 Win2000
おはようございます。
朝起きてぱっと見ただけで、、なんか嫌な予感がしないわけでもないのですが、、
多分、、？？？こんな感じかと思います。
昨日の今日なんで少しショックが残っていて、
最後まで、お付き合いできないかとは思いますが、とりあえずこんな方法もあり
という程度でお考え下さい。
動けばいいじゃんマクロで外してても許してくれるという寛大なお気持ちのもと、、？
でよければ、使ってみてください。
では、、清水の舞台より、ダイブしてみます。。。
（夏目雅子似）
↓これを全てのシートに貼り付けて下さい
'当該シートがアクティブになったら、製品番号をキーにソートする。
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Range("A1").CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
Application.ScreenUpdating = True
End Sub
↓これを受注シートに貼り付けてください
'受注シート用
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KR As Integer
Dim R As Integer
Dim C As Integer
Dim i As Integer
If Target.Count > 1 Then Exit Sub
If Target.Column <> Range("A:A").Column Then Exit Sub
i = Range("A1").End(xlToRight).Column()
MsgBox i←消して下さい。
KR = Sheets("完成").Range("B65536").End(xlUp).Row() + 1
MsgBox KR←消して下さい。
R = Target.Row MsgBox R←消して下さい。
Application.EnableEvents = False
If Target.Value = "完成" Then
For C = 1 To i
Sheets("完成").Cells(KR, C).Value = Cells(R, C).Value
Next C
Target.EntireRow.Delete Shift:=xlUp ’訂正
End If
Application.EnableEvents = True
End Sub
↓これを完成シートに貼り付けて下さい
'完成シート用
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KR As Integer
Dim R As Integer
Dim C As Integer
Dim i As Integer
If Target.Count > 1 Then Exit Sub
If Target.Column <> Range("A:A").Column Then Exit Sub
i = Range("A1").End(xlToRight).Column()
MsgBox i←消して下さい。
'▲完成シートから出荷シートへの転記する為の最終行+1を取得しています。
'従って、Sheets("出荷")を転記先のシート名に変更にして下さい。
KR = Sheets("出荷").Range("B65536").End(xlUp).Row() + 1
MsgBox KR←消して下さい。
R = Target.Row MsgBox R←消して下さい。
Application.EnableEvents = False
'▲入力した文字が「出荷」だったら「出荷」と言う名前のシートに転記を実行します。
'従って"出荷"と言う文字を実行したい文字に変更してください。
If Target.Value = "出荷" Then
For C = 1 To i
Sheets("出荷").Cells(KR, C).Value = Cells(R, C).Value
Next C
Target.EntireRow.Delete Shift:=xlUp ’訂正
End If
Application.EnableEvents = True End Sub 多分？動くと思いますが、外してたら、、ごめんなさいm(__)m では、行ってきます。
ど素人の為、意味がわかりません。
また、どんような場面で↑を貼り付けてよいのかわかりません。
マクロは、メニューを広げたこともありません。
どうか、後学のために意味も教えて下さい。
違う場面で応用がきくように。
宜しく御願いします。
「ツール」「マクロ」 Visual Basic Editorをクリック
左側のプロジェクトにブック内に存在するsheetがツリー型で表示されていますよね！
そのsheet（受注、完成、出荷）をダブルクリックして上記の構文を貼り付ける
という作業だと思います。
（HISA)
HISAさまありがとうございました。
また、マクロを教えて頂いたお方さま、ありがとうございました。
すばらしい～！
自分が想像していたこんなことできたらな～と思っていたこと以上にすばらしい～動き！
鳥肌がたちました。
後学のために式の意味も教えて頂けませんか？
あっ、すみませ～ん！
今、受注シートに新規データを入力し、A列に"受注"と入力したとたん、マクロが起動し、データが、受注シートに残らなくなってしまいました。
A列が受注の場合は、このシート上に残したいのですが・・・。
データどこに行ったのでしょうか？
教えて下さい。
宜しく御願いします。
コードを見ましたが、A列に何らかの変更がされると元データは削除されてしますようです。
'受注シート用マクロと '完成シート用マクロの中にある
Target.EntireRow.Delete Shift:=xlUp
を If ......... End Ifの中に入れてあげる必要があります。
受注シート用マクロ
If Target.Value = "完成" Then
For C = 1 To i
Sheets("完成").Cells(KR, C).Value = Cells(R, C).Value
Next C
Target.EntireRow.Delete Shift:=xlUp
End If
完成シート用マクロ
If Target.Value = "出荷" Then
For C = 1 To i
Sheets("出荷").Cells(KR, C).Value = Cells(R, C).Value
Next C
Target.EntireRow.Delete Shift:=xlUp
End If
にして両方の元の位置あるTarget.EntireRow.Delete Shift:=xlUp を削除 すれば、ＯＫだと思うのですが。 (jindon)
jindon さま ありがとうございました。
受注シートに↑をコピーして、A列データー 受注 → 完成 としたら
実行424エラー
オブジェクト 確認して下さい。
Target.EntireRow.Delete Shift:=xlUp
にチェックが入ってしまいました。
何故？
よく確認しませんでした。 ↑訂正してありますので。大丈夫だと思うのですが。
もし、マクロが作動しなかったら Application.EnabelEvents がFalseの状態 のままかもしれませんので、
Sub Test()
Application.EnabelEvents=True
End Sub
を ThisWorkbookのモジュールに貼り付けて作動させてください。
方法： シートタブを右クリックしてVBE画面に入り、左画面のThisWorkbookをダブルクリック。 上記のコードを貼り付けて、excel画面に戻り ツール→マクロ→マクロ→ThisWorkbook.Testを選択して 実行 です。
かえって、ややこしくしてしまって申し訳ありません。
(jindon)
ぎゃ～～～、また、また、ずっこけたみたいで汗(>_<) HISA様 jindon様フォローありがとうございます。m(__)m トピ主のあっちゃん様どうか、お許しくださいませm(__)m 私、ただいまバリ仕事中(*_*) 訂正しておきました。m(__)m （夏目雅子似）
jindon さま ありがとうございました。
「↑訂正してありますので。大丈夫だと思うのですが。」
この部分だけで動きました。
感謝！感謝！です。
みなさま 本当にありがとうございました。
また、是非教えて下さい。
（あっちゃん）
お久しぶりです。
以前教えて頂いてから毎日毎日使わせて頂いています。
ですが、だんだん欲が出来てしまって～（；^^A）
また教えて下さい。
１．新しくファイルを作り、1つのシートを次々（2つ計3シート）コピーして、以前教えて頂いたマクロをコピーし貼り付けました。
が、
実行時エラー“1004”
同じサイズの結合セルが必要
と出てきます。？？？ 何故でしょうか？
２．以前お聞きした時は、“受注”“完成”“出荷”という3シートでしたが、“受注”“製作中－1”“製作中－2”“完成－1”“完成－2”など計11シートを作成し、出荷管理表を詳細にしたいと思います。
どのように、マクロを変更したらよいでしょうか？
３．ずうずうしいお願いなのですが、
Ａ列のデータを変更する度に
Microsoft Excel 256 OK
Microsoft Excel 6 OK
Microsoft Excel 6 OK
と聞いてきます。
これをパスできないでしょうか？
よろしくお願いいたします。
こんばんわ！あっちゃん様、トピを見ていたら、私の名前がぁ(@_@) >実行時エラー“1004” >同じサイズの結合セルが必要
>と出てきます。？？？ 何故でしょうか？
これは、その名の通り結合セルがある為と思われます。 結合セルを解除して下さい。
>２．以前お聞きした時は、“受注”“完成”“出荷”という3シートでしたが、“受注”“製 作>中－1”“製作中－2”“完成－1”“完成－2”など計11シートを作成し、出荷管理表 を詳細に>したいと思います。 >どのように、マクロを変更したらよいでしょうか？
上のコードに▲で説明を入れましたので、応用してください。
>と聞いてきます。 >これをパスできないでしょうか？ これは、私の癖といいますかぁ、、↓の為です。 これを、消してください。m(__)m 上のコードには一応書いておきました。ごめんなさいm(__)m （夏目雅子似） MsgBox R←消して下さい。 MsgBoxとある個所を全て消して下さい。
１．「実行エラー」について、以前の同じ３つのシートをコピーし、コマンドを貼り付けました。
結合箇所は確かに１箇所あった（以前の時もあった）ので結合解除し、再度行なってみました。
"受注"シートからデータは"完成"シートには移動したのですが、やはりダメでした。
シート内のデータは６行目から始まっています。（日付・会社名等を入れたため）
このことが、このエラーの要因になっているのでしょうか？
デバックを確認しましたら、下記のコマンドが黄色になっていました。
Range("A1").CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
追記）
何度も追記をしてすみません！
ルール違反なのでしょうね～.（ごめんなさい）
１．のことについてですが、
結合個所が別の所にもあり、解除したらよかったのですが、
今度は違うエラーメッセージがでて来ました。
実行時エラー"1004"
Rarge クラスの Sort メソッドが失敗しました。
と出て、デバックを確認したら、やはり上記のコマンドが黄色でした。
２．以降はまだ１．が出来ないので、進まない状態です。
ちなみに
２．３シート → １１シートについてのコマンド変更についてですが、
必ず“受注”→“製作中－１”に行くわけではなく
“受注”→“製作中－２”や“製作中－３” etc（－１、２、３は商品の分類に使っている）
どれに行くかわかりません。
もしかしたら、諸般の事情により
“受注”→“完成－１”
になるかも～
Ａ列がどれになっても、その「シート名」に行くのでしょうか？
お忙しい中申し訳有りませんが、宜しく御願いします。
衝突しましたぁ、、
色々とある様ですが、一つづついきましょう。
まず、
>シート内のデータは６行目から始まっています。（日付・会社名等を入れたため）
>このことが、このエラーの要因になっているのでしょうか？
これは、
私の提示したコードがA1を含む範囲としている為です。
従ってコードを↓に変更してください。
Range("A6").CurrentRegion.Sort Key1:=Range("B7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
それから、A6を選択した状態でCtrl+*を押して選択される範囲が
今回のデータの範囲となりますから、A6とA5が繋がっていると
選択されてしまいます。
その様な場合は、一行あけるなどの工夫が必要です。
それと、↑のコードは並べ替えを記録したものを編集しただけですから
ご自身で記録されてみるとよいでしょう。
で、どうでしょう？
（夏目雅子似）
今、動いたのですが、"受注"シート用、または"完成"シート用だけのプログラムで
i=Range("A1").End(xl ToRight).Column()の
"A1" は "A6" に変更すべきでしょうか？
現在は、問題動いていますが～
また、申し訳有りません。
お手を煩わせますが、次の↑の質問（２～３）もお教え願えませんか？
宜しく御願いします。（あっちゃん）
またまた、追記ですみません。
データは、Ａ列"受注""完成""出荷"の項目、Ｖ列備考まであります。
夏目雅子似様のおっしゃっています
A6 にて”Ctri ＋ ＊”をしますと範囲を示す色の変化は
A4：I6
となっています。
ご指示通り１行入れ
A6 で”Ctri ＋ ＊”をしますと範囲を示す色の変化はありません。
“”受注”シートに１行入れ、また”完成”シート”出荷”シートにも１行入れ
データを入れ、Ａ列を”受注” → “完成”にすると
５行目
つまり、本来挿入したい位置より１行上になってしまいます。
また、
“”受注”シートに１行入れ、”完成”シートと”出荷”シートは、そのまま（”完成”と”出荷”シートＡ列にCtri ＋ ＊すると、Ａ4：Ｉ６になります。）にし、I列までデータを入れると
本来挿入してほしいところにデータがきます。
しかし、”受注”シートＪ列にデータを入れたとたん、表は乱れてしまいます。
そこで、
夏目似様のおっしゃっています、１行入れるとは、どのシートの時でしょうか？
また、Ｊ列に入っているデータ → 入力規則 → リスト は悪影響があるのでしょうか？
（各シートの同じ位置にリスト因子は置いてあります）
それとも、今回は範囲（Ａ4：Ｉ６）が原因でしょうか？
よろしくお願いいたします。（あっちゃん）
あっちゃんさん こんばんは^^
>夏目似様のおっしゃっています、１行入れるとは、どのシートの時でしょうか？
（様はいりません^^;）
私が言いたいのは
Range("A6").CurrentRegion
を使っているので5行目は空白にしておいて欲しいということです。
つまり、A5に何かがあるとA6を選択した状態でCtrl+*とすると
範囲にA5も含まれませんか？
A1 B1 C1 D1 E1 F1 D1
1** ** ** ** ** ** **
2** ** ** ** ** ** **
3** ** ** ** ** ** **
4** ** ** ** ** ** **
5
6項目1項目2項目3項目4項目5項目6
7****************************
8****************************
9****************************
10***************************
と、なっていて欲しいのです。
さて、それはさておきコードを少し変更してみましたので差し替えてください。
今回のコードはA列に入力したシート名にその行のデータを転記するものです。
例えば、
製作中－2と入力すれば、製作中－2へ
完成－1と入力すれば、完成－1へ
完成－2と入力すれば、完成－2へ転記します。
転記先のシートが無い場合は、メッセージを表示します。
また、自分から自分へは転記しません。
つまり
完成－1シートを選択している状態で完成－1と入力しても転記しません。
コードに区別はありません。全シート共通です。
ただ、
A6からリストがあること。
A5行が空白であること。
が条件です。
で、どうでしょう？
（夏目雅子似）
'当該シートが選択されたらB列をキーにソートする。
Private Sub Worksheet_Activate()
Range("A6").CurrentRegion.Sort Key1:=Range("B7"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
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
'ターゲットの列がA列以外か行が7行より小さかったら無効
If Target.Column <> 1 Or Target.Row < 7 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 = 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
'イベントを有効にする。
Application.EnableEvents = True
End Sub
データをたまたま今はＯ列まで（全体ではＶ列まで）しか入力をしなかった場合、そのデータまでは、そのＡ列記入のシート名のところまでは飛びます。
しかし、挿入状態がうまく行かず、表が乱れます。
今は、
切り取り → 切り取ったセルの挿入（下方向へシフト）
という感じで入ってくるのです。
自分がなってほしいのは、
行の切り取り → （７行目以降に）切り取った行の挿入です。
そして、Ｂ列をキーにしたソートの実行。
現在は、挑戦をすればするほど、１行目、３行目、２行目などまちまちになってしまいます。
つたない、説明で申し訳有りません。
各シートのフォーマットは受注シートと同じです。（これがいけないのかな～）
それから
Ａ列で入力された項目と同じシート名に移動はしました。
さすが～夏目雅子似 様！
宜しく御願いします。
すみません。いまいちよく分からないのですが、
シートのレイアウトを教えていただけませんか？
↓こんな感じで
（夏目雅子似）
A1 B1 C1 D1 E1 F1 D1
1** ** ** ** ** ** **
2** ** ** ** ** ** **
3** ** ** ** ** ** **
4** ** ** ** ** ** **
5
6項目1項目2項目3項目4項目5項目6←ここから下を対象にしています。
7**************************** ↓リスト
8**************************** だから
9**************************** Range("A6").CurrentRegion
10*************************** なんです。A6がリストの左上端でしょ？
それから、
>A6からリストがあること。
>A5行が空白であること。
この条件は満たされていますか？
>シート内のデータは６行目から始まっています。（日付・会社名等を入れたため）
>このことが、このエラーの要因になっているのでしょうか？
で、
>A6 にて”Ctri ＋ ＊”をしますと範囲を示す色の変化は
>A4：I6
>となっています。
今回の私が提示したコードは
Range("A6").CurrentRegion
で、選択される範囲、つまり
A6でCtrl+*した範囲を対象にしています。
どこに、リストがあるのかわかりませんが、リストの左上端を
A6に置き換えていただけませんか？
意味わかりますか？
（夏目雅子似）
A1 B1 C1 D1 E1 F1 D1 1** ** ** ** ** ** ** 2** ** ** ** ** ** ** 3** ** ** ** ** ** ** 4** ** ** ** ** ** ** 5項目1項目2項目3項目4項目5項目6 6 7**************************** 8**************************** 9**************************** 10***************************
上記のフォーマットのように、空行をただつくれればいいのでしょ？
なんて勝手に思い込んでいました。
頭の中を一度精算し、夏目雅子様のおっしゃています通りに
フォーマットしてみました。
以前のフォーマットを崩せないので
行を「表示しない」というものを使いながら。
また、I6とK6の間のJ6の項目が「空」になっていました。
ここに「スペース」を1ついれてみましたら、希望するV6までデータが行くようになりました。
自分では、軽く見ていた空のセルの影響を強く感じました。
ここ数日、あなた様の大事な時間を私のために使っていただきありがとうございました。
（コード内容の説明もありがとうございました）
また、これに懲りずに教えて下さい。（あっちゃん）
あっちゃんさん、こんにちは^^
解決したのかな？
>頭の中を一度精算し、夏目雅子様のおっしゃています通りに
>フォーマットしてみました。
あのぅ、コードにシートのレイアウトをあわせなくても
A6をリストの左上端の番地に変更していただければいいのですがぁ、、
例えば、A7だったらA7でもいいですし、、
>また、I6とK6の間のJ6の項目が「空」になっていました。
これも、今は
.Range("A6").End(xlToRight).Column
としてA6から右にカウントしていますが
途中に空白が必要なら
.Range("IV6").End(xlToLeft).Column
として右端から左にカウントすることもできますし、、
今回の（いつも？）私のコードは全然難しくないです。汗
ポイントは
A6がリストの左端上隅であること
リストの最終行をB列で判断していることと
Range("A6").CurrentRegion
を使っているので範囲は実際にその番地でCtrl+*されて確かめられたら
いいかと思います。
後は、並び替えのところにB7がありますが、これなんかはA6に対してB7と考えて
いただければよろしいかと思います。
それから、並び替えなどは、ほとんどマクロの記録そのままですから
実際に記録されてみてはいかがでしょうか？
>ここ数日、あなた様の大事な時間を私のために使っていただきありがとうございました。
全然お気になさらないでくださいませ。
それよりも、私の方こそシートのレイアウトが理解できなくてごめんなさいねm(__)m
あっ、少しコードを修正しましたので、よかったら差し替えてください。
それでは、今後とも、よろしくお願い致します。
（夏目雅子似）
なんとお優しい言葉でしょう（T-T）（m-m）感謝！
ところで、ずうずうしいお話ですが、もう１つ教えて下さい。
B列に記入されている最終行までを、印刷するにはどのようにすればよいでしょうか？
各シート行数が変わるので～！
すみません。宜しく御願いします。
いろんな方法があるとおもいますが、
ThisWorkBookのBeforePrintを使うのはどうでしょう？
プロジェクトウィンドウのThisWorkBookをダブルクリックして
コードを表示させてそこに↓を貼り付けます。
プロジェクトウィンドウはシートのコードを貼り付けた
左上にあるとおもいます。
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim MeRow As Long
Dim MeCol As String
With ActiveSheet
'B列の最終行を取得
MeRow = .Range("B65536").End(xlUp).Row
'リストの最右列の列番地を取得
MeCol = .Range("IV6").End(xlToLeft).Address
'各シートの印刷範囲を設定
.PageSetup.PrintArea = "A6" & ":" & Mid(MeCol, 2, 1) & MeRow
End With
End Sub
それから、リストにも途中に空白があるのですね？
それでしたら、↓の様にCellsを使って範囲を可変にされてはどうでしょう？
'当該シートが選択されたらB列をキーにソートする。
Private Sub Worksheet_Activate()
Dim MeRow As Long
Dim MeCol As Integer
'B列の最終行を取得
MeRow = Range("B65536").End(xlUp).Row
'6行目の最右列を取得
MeCol = Range("IV6").End(xlToLeft).Column
'MeRowとMeColを使ってデータ範囲を設定してソートする。
Range("A6", Cells(MeRow, MeCol)).Sort Key1:=Range("B7"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub
転記コードの途中にある↓も
.Range("A6").End(xlToRight).Column
これに↓に変更された方がよろしいかと思います。
.Range("IV6").End(xlToLeft).Column
で、どうでしょう？
(夏目雅子似）
夏目似様 ありがとうございます。
（m_m）（m_m）何とお詫びをして良いかと・・・。
うまくいったので、図に乗って、フォーマットを変更しました。
そしたら、ダメになってしまいました。
行は下記のようにしました。
1 空行
2 リストアップ用データ
3 リストアップ用データ
～ リストアップ用データ
20 リストアップ用データ
21 空行
22 日付
23 会社名
24 部署
25 空行
26 項目
27 データ
28 データ
29～データ続く
です。
ThisWorkbook には
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim MeRow As Long
Dim MeCol As String
With ActiveSheet
MeRow = .Range("B65536").End(xlUp).Row
MsgBox MeRow'←追加 ▲ちなみにここは印刷の幅を決めるところですから最大になる行がよろしいかとおもいます。IV26ぐらいかな？(^^)v
MeCol = .Range("IV22").End(xlToLeft).Address
MsgBox MeCol'←追加 ▲ちなみにA22から印刷したい場合はA26→A22に(^^)v
.PageSetup.PrintArea = "A26" & ":" & Mid(MeCol, 2, 1) & MeRow
MsgBox .PageSetup.PrintArea'←追加
End With
End Sub を
各シートには
Private Sub Worksheet_Activate()
Dim MeRow As Long
Dim MeCol As Integer
MeRow = Range("B65536").End(xlUp).Row
MeCol = Range("IV26").End(xlToLeft).Column'▲←ここがない(>_<)
Range("A26", Cells(MeRow, MeCol)).Sort Key1:=Range("B27"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
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
If Target.Column <> 1 Or Target.Row < 7 Then Exit Sub
If Target.Count > 1 Then Exit Sub
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 = 0
If Wks.Name = tennki_saki Then
MyRow = Sheets(tennki_saki).Range("B65536").End(xlUp).Row + 1
With Me
For C = 1 To .Range("IV26").End(xlToLeft).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
Next
If i <> 0 Then
MsgBox "転記先のシート 「" & tennki_saki & "」 は、ありません。" & Chr(13) & _
"転記先のシート名が正しいかもう一度確認して下さい。", vbCritical, "Excelの学校 VBA"
End If
Application.EnableEvents = True
End Sub とコードを変更して貼付けました。
うまく行かないのは「印刷」です。
また、実行エラー"1004"
アプリケーションエラー とでます。
是非、宜しく御願い致します。
印刷のコードにメッセージボックスを追加しましたので、 プレビューを押してどの様に表示されるか確認してくださいませんか？ こちらでは、別段問題はありませんでした。 （夏目雅子似）
または、印刷のコードだけを新規ブックでテストしてみていただけませんか？
または、標準モジュールを挿入して
Sub 印刷範囲（）
Dim MeRow As Long
Dim MeCol As String
With ActiveSheet
MeRow = .Range("B65536").End(xlUp).Row
MsgBox MeRow'←追加
MeCol = .Range("IV22").End(xlToLeft).Address
MsgBox MeCol'←追加
.PageSetup.PrintArea = "A26" & ":" & Mid(MeCol, 2, 1) & MeRow
MsgBox .PageSetup.PrintArea'←追加
End With
End Sub
としてF8で一つづつ確認していただけませんか？
よろしくお願いします。
（夏目雅子似）
または、↓としてどうなりますか？
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim MeRow As Long
Dim MeCol As Integer
With ActiveSheet
MeRow = .Range("B65536").End(xlUp).Row
MsgBox MeRow
MeCol = .Range("IV22").End(xlToLeft).Column
MsgBox MeCol
.PageSetup.PrintArea = Range("A26", Cells(MeRow, MeCol)).Address
MsgBox .PageSetup.PrintArea
End With
End Sub
割り込み失礼。ちょっと助け舟。
こちらではWorksheet_Activateイベントでエラーが出ます。
変数MeColが取得されていないのでは？
MeCol = Range("IV6").End(xlToLeft).Column
を誤って削除したものと推測します。
Workbook_BeforePrintイベントは問題ないように思えます。
(KAMIYA)
KAMIYA様 ありがとうございます。m(__)m
実は、あせりまっくていましたぁ^^;
ほんとですね。↓がないですね。
MeCol = Range("IV6").End(xlToLeft).Column
あっちゃんさん、という事ですのでよろしくお願いします。m(__)m
（夏目雅子似）
みなさんに、ご迷惑をおかけして申し訳ありません。（m_m）
始めに問い合わせて頂いていた時とは、フォーマットを変更したため
以前の項目を６行目 → 26行目にしました。また、印刷をしてほしいのは、会社名含め、２２行目からです。
このような理由から、
MeCol = .Range("IV6").End(xlToLeft).Address
↓
MeCol = .Range("IV22").End(xlToLeft).Address
に勝手にしてしまいました。
ダメだったのでしょうか？
また、
上記印刷の内容をどのようにやっていいのか分からなかったので、ThisWorkbookにコードを貼り付けました。
何度かテストを繰り返しているうちに、
実行エラー”1004”
アプリケーション定義またはオブジェクト定義のエラー とでます。
デバックを確認すると、各シートの下記のコードが黄色になります。
Range("A26", Cells(MeRow, MeCol)).Sort Key1:=Range("B27"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub
さきに進めません。
よろしくお願いいたします。
あのぅ、、
MeCol = .Range("IV6").End(xlToLeft).Address
↓
MeCol = .Range("IV22").End(xlToLeft).Address
は、問題ないと思います。
実行エラーはシートを選択した時に発生するのではないですか？
印刷のマクロは印刷を実行する前に発生するイベントですから、
コードをThisWorkBookに貼り付けたら後はプレビューをクリックするか
印刷をクリックすれば自動的に印刷範囲が設定されます。
もしも、動きを確認されたいのでしたら、標準モジュールに貼り付けてF8で確認されて
みてもいいでしょう。
それから、不具合個所に▲マークで印を付けてみましたので、確認してください。
何とか解決されるといいですね(^^)V
で、どうでしょう？
（夏目雅子似）
うまくいきました。
夏目雅子似様のおっしゃる通り、
実行エラーはシートを選択した時に発生するのではないですか？
その通りです。
KAMIYA様のおっしゃる通り、１行コードが抜けていました。
あせまくっている上、思い込みが激しい私は、自分の過ちを「きちん」と認識せず、
夏目雅子似様に指摘頂き、▲までつけて頂き、本当に感謝です。
今は、もう家でデータを１０個程度しか持ち帰ってきていません。
月曜日にすべてのデータを移してみます。
問題が発生したら是非教えて下さい。
また、月曜日にでもご報告させていただきます。
この数日、夏目似様ありがとうございました。
KAMIYA様も、ありがとうございました。
（あっちゃん）
よかったですね。また、少し気になったところがありましたので ▲マークで二つほど入れておきましたので確認してください。 では、(^^)v （夏目雅子似）
週末は、お陰様で気持ちよく過ごさせて頂きました。
ありがとうございました。（m_m）
早速、朝から馬力（豚力）を出して、データを移しました。
印刷部分が何故かうまく行かなかったので、▲マークをつけて頂いたコードを貼り付けました。
バッチリです。
涙がポロポロ。
ありがとうございました。
また、問題がいつか起こったら、是非懲りずに教えて下さい。
宜しく御願いします。（あっちゃん）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.