- ベストアンサー
VBAを使ってEXCEL2010で業務スケジュール表を作成する方法
mar00の回答
- mar00
- ベストアンサー率36% (158/430)
動作確認はしていませんので、ブックをコピーするなどしてから確認してみてください。 Private Sub 登録_Click() Dim row As Integer row = WorksheetFunction.CountA(Sheets("スケジュール").Columns(1)) + 1 Sheets("スケジュール").Cells(row, 1).Value = Range("Q2").Value myRow = 1 For i = 7 To 19 Step 6 For j = 6 To 24 Step 2 myRow = myRow + 1 With Sheets("スケジュール").Cells(row, myRow) .Value = Cells(j, i).Value .WrapText = True '折り返して全体を表示する End With Next j Next i Range("Q1").Select End Sub
関連するQ&A
- ＶＢＡ 重複する番号があるときは値を貼り付けない
すみません。 理解しているのが少しなので、ちょっとシンプルなＶＢＡを書いています。 1つのブックに 登録シート ＝Sheets("登録") 顧客情報シート＝Sheets("顧客情報") 販売情報シート＝Sheets("販売情報") 売り上げシート＝Sheets("売り上げ") 登録シートのボタンを押すと、登録シートに入力した情報が、 各シートに分かれて値が入るようにしています。 下記がコードです。 Private Sub CommandButton1_Click() Dim row As Integer ★★★ row = WorksheetFunction.CountA(Sheets("顧客情報").Columns(2)) + 1 Sheets("顧客情報").Cells(row, 2).Value = Range("A2").Value Sheets("顧客情報").Cells(row, 3).Value = Range("A5").Value Sheets("顧客情報").Cells(row, 4).Value = Range("B8").Value ★★★ row = WorksheetFunction.CountA(Sheets("販売情報").Columns(2)) + 1 Sheets("販売情報").Cells(row, 2).Value = Range("C26").Value Sheets("販売情報").Cells(row, 3).Value = Range("J1").Value row = WorksheetFunction.CountA(Sheets("売り上げ").Columns(2)) + 1 Sheets("売り上げ").Cells(row, 2).Value = Range("H1").Value Sheets("売り上げ").Cells(row, 3).Value = Range("K6").Value End Sub もっと簡単な書き方あるよ。。。と言われるでしょうが、 私が理解して修正等ができるのが、上記でした。。 やりたいことは、２点です。 (1)重複は貼り付けをしない。 登録シートのセル A2に入った数字が、顧客情報シートのＢ列のどこかに、 既に入力がされていた場合は、★★★で囲まれた部分の値を貼り付けず、 その先の販売情報のシートに貼り付ける作業へと進めたい。 ＩＦ などを使えばできますでしょうか？ (2)各シートに入力したものを貼り付けた際、Ａ2より下から順番に各シートのCells(row, １)の位置に、連番をつけたい。 何卒宜しくお願い申し上げます。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAについて
こんにちわ！ 今、エクセルでAシートの入力した項目をBのシートへデーターが入力できるようなシステムを以下のようにくみました。 そこでBシートにデーターが入力されるのですが２０行まで入力すると入力できないようにしたいのですが、なかなか上手くいきません。 A1からF20まで書式のロックを外しそれ以外のセルは保護をかけたのですがその状態でVBAを使って２０行以上入力できませんという感じのエラー表示をしたいのですが、どうすればいいでしょうか？ VBAは初心者ですが宜しくお願いします。 Private Sub CommandButton1_Click() Dim row As Integer row = WorksheetFunction.CountA(Sheets("date").Columns(1)) + 1 Sheets("date").Cells(row, 1).Value = Range("B2").Value row = WorksheetFunction.CountA(Sheets("date").Columns(2)) + 1 Sheets("date").Cells(row, 2).Value = Range("B3").Value row = WorksheetFunction.CountA(Sheets("date").Columns(3)) + 1 Sheets("date").Cells(row, 3).Value = Range("B4").Value row = WorksheetFunction.CountA(Sheets("date").Columns(4)) + 1 Sheets("date").Cells(row, 4).Value = Range("B5").Value row = WorksheetFunction.CountA(Sheets("date").Columns(5)) + 1 Sheets("date").Cells(row, 5).Value = Range("B6").Value row = WorksheetFunction.CountA(Sheets("date").Columns(6)) + 1 Sheets("date").Cells(row, 6).Value = Range("B7").Value Sheets("統制入力").Select Range("B17").Select ActiveWindow.SmallScroll Down:=-9 Range("B3:B7").Select Selection.ClearContents Range("B1").Select End Sub
- ベストアンサー
- Visual Basic
- ＶＢＡの転記について
With Sheets("入力") '3行目～22行目まで For i = 5 To 24 SheetName = Sheets("入力").Cells(i, "C").Value On Error Resume Next Set Dummy = Sheets(SheetName) SheetName2 = .Cells(i, "C").Value U最終行 = Sheets(SheetName2).Range("C65536").End(xlUp).Row + 1 If U最終行 = 39 Then Sheets(SheetName2).Copy BEFORE:=ActiveSheet Sheets(SheetName).Delete End If If Err.Number = 0 Then A = Sheets(SheetName2).Range("C65536").End(xlUp).Row + 1 Sheets(SheetName2).Range("C" & A).Value = .Cells(i, "G").Value Sheets(SheetName2).Range("D" & A).Value = .Cells(i, "I").Value Sheets(SheetName2).Range("E" & A).Value = .Cells(i, "L").Value Sheets(SheetName2).Range("F" & A).Value = .Cells(i, "N").Value Sheets(SheetName2).Range("G" & A).Value = .Cells(i, "P").Value Sheets(SheetName2).Range("H" & A).Value = .Cells(i, "R").Value Sheets(SheetName2).Range("I" & A).Value = .Cells(i, "T").Value Sheets(SheetName2).Range("K" & A).Value = .Cells(i, "V").Value Sheets(SheetName2).Range("L" & A).Value = .Cells(i, "X").Value ElseIf .Cells(i, "C").Value <> "" Then G = Sheets("原紙").Range("C65536").End(xlUp).Row + 1 Sheets("原紙").Range("B1").Value = .Cells(i, "D").Value Sheets("原紙").Range("B4").Value = .Cells(2, "D").Value Sheets("原紙").Range("C" & G).Value = .Cells(i, "G").Value Sheets("原紙").Range("D" & G).Value = .Cells(i, "I").Value Sheets("原紙").Range("E" & G).Value = .Cells(i, "L").Value Sheets("原紙").Range("F" & G).Value = .Cells(i, "N").Value Sheets("原紙").Range("G" & G).Value = .Cells(i, "P").Value Sheets("原紙").Range("H" & G).Value = .Cells(i, "R").Value Sheets("原紙").Range("I" & G).Value = .Cells(i, "T").Value Sheets("原紙").Range("K" & G).Value = .Cells(i, "V").Value Sheets("原紙").Range("L" & G).Value = .Cells(i, "X").Value '原紙をコピーする Sheets("原紙").Copy BEFORE:=Sheets(1) 'シートの名前を市場コードにする Sheets(1).Name = SheetName End If Next i End With On Error GoTo 0 上記のＶＢＡを作成しましたが、 C行の値ごとの転記(Ｇ～Ｘの値)が出来ません。 どこが間違いか教えていただけないでしょうか。
- ベストアンサー
- Visual Basic
- VBA で２つのプロシージャを一つにまとめたい
いつもここにはお世話になっており、ありがとうございます。 さて、タイトルにもありました通り、下記２つのプロシージャでコマンドボタンを設定して、実行しておりますが、これを一つのプロシージャ（ボタン）にまとめたく、ご指導お願いいたします。 ○作ろうとしているＶＢＡの概要 １）EXCELのデータベースで、一枚目の「inputシート」に入力し、２枚目の「dataシート」でデータをどんどん格納していきます。 ２）データは、「顧客ＣＤボタン」で管理しており、これをキーとしています。 ３）「顧客ＣＤ」は[inputシート」ではＣ４セル、「ｄａｔａシート」ではＡ列にで管理しています。 ３）データは新規にデータを入力したときの登録ボタン（一つ目のプロシージャ）、既存のデータを編集して、上書きするときの、変更登録ボタン（二つ目のプロシージャ）があります。 ○相談したい内容 「登録ボタン」と「変更」ボタンを一つにまとめて、ひとつのボタンとして、新規にデータを登録するときも、変更したデータを登録するときも、同じボタンで行えるようにしたい。 '■１つ目のプロシージャー Private Sub CommandButton1_Click() '登録ボタン Dim row As Integer row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 2).Value = Range("C5").Value row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 3).Value = Range("C6").Value row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 4).Value = Range("C7").Value row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 5).Value = Range("F5").Value ActiveWorkbook.Save End Sub '■２つ目のプロシージャー Private Sub CommandButton3_Click() '変更ボタン Dim fRange As Range Dim fRow As Long If (Range("C4").Value = "") Then '顧客CDが入力されていない？ MsgBox "顧客コードを入力してください。", vbExclamation Exit Sub End If Set fRange = Sheets("data").Columns(1).Find(What:=Range("C4").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) If (fRange Is Nothing) Then '見つからなかった？ MsgBox "入力された顧客コードが存在しません。", vbExclamation Exit Sub End If fRow = fRange.row '検索された顧客DCの行位置を求める Sheets("data").Cells(fRow, 2).Value = Range("C5").Value Sheets("data").Cells(fRow, 2).Value = Range("C5").Value Sheets("data").Cells(fRow, 2).Value = Range("C5").Value Sheets("data").Cells(fRow, 3).Value = Range("F5").Value
- ベストアンサー
- オフィス系ソフト
- VBAについて
Excel2010使用。 VBA初心者である為、 何度か質問させていただきながら 回答いただいた内容に修正を加えつつ、 思いのものがひと通りできたと 解決していたつもりだったのですが、 動作確認をしたところ、一部不具合が生じました。 自己解決を試みているのですが、解決できず困っております。 どなたかお助けいただけないでしょうか？ Private Sub 登録_Click() '登録ボタン押下で勤務表にデータを登録 Dim row As Integer Application.ScreenUpdating = False '画面更新の抑制 row = WorksheetFunction.CountA(Sheets("勤務表").Columns(1)) + 1 myCol = 1 Sheets("勤務表").Cells(row, 1).Value = Range("T2").Value Sheets("勤務表").Cells(row, 34).Value = Range("T1").Value For i = 8 To 22 Step 7 For j = 6 To 26 Step 2 If IsEmpty(Cells(j, i)) Then Exit For Else myCol = myCol + 1 With Sheets("勤務表").Cells(row, myCol) .Value = Cells(j, i).Value If LenB(StrConv(Cells(j, i).Value, vbFromUnicode)) > 8 Then '(1) ここを修正 .WrapText = True .Font.Size = 6 End If End With End If Next j Next i Sheets("勤務表").Cells(5, 22).Value = Range("P3").Value '月末日を移す Range("T1").ClearContents '連続入力の為、消去 Range("E6:G25").ClearContents Range("L6:N25").ClearContents Range("S6:U27").ClearContents Application.ScreenUpdating = True '抑制の解除 Range("T1").Select End Sub 上記コードを作成し、 入力用のシートから勤務表シートに 1人ずつ登録していくようにしております。 入力用のシートのH6:H24、O6:O24、V6:V26 （シートの都合により2行を1行に結合しています） このマクロを実行したところ、 V24までは転記ができているのですが、 V26だけが転記できない状況となっています。 CellsでいくとCells（22,26）まで範囲に入っていると 思うのですが・・・。 どこがおかしいのでしょうか？
- ベストアンサー
- その他MS Office製品
- VBAのコードを見ていただけませんか
いつも、ここのサイトの方々には大変お世話になっております。ありがとうございます。 さてexcel2000で、dataというフォームにデータを格納し、メインのシートから、読みに行って編集するデータベースを作成しようとしています。 とあるサイトを参考にして、コードを作成しましたが、いくら頑張ってもどうしてもエラーが出てしまいうまくいきません。 どうか、コードのチェック・修正内容の提案等をいただけないでしょうか？よろしくお願いいたします。 (1)自分で登録した「ＩＤが見つかりません」という表示しかでず、登録が出来ない (2)dataシートのＢ列（２列目）が主キー(ＩＤと呼んでいます） です。（メインのシートとデータを照合させる部分） (3)メインのシートのＩＤはAL1～AQ1行セルまでを結合したセルに保管しています。 (4)下記コードでCommandButton1ボタンを「登録」と命名し、メインシートで入力したデータをdataシートに変更登録、新規に入力したデータも登録できるようにしたい。 (5)スピンボタンでＩＤを変化させて、メインフォーム上のデータも変化させたいけど、こちらも同種のエラーが出てしまう。 ■以下コードです。 Private Sub CommandButton1_Click() Dim fRange As Range Dim fRow As Long If (Range("AL1").Value = "") Then 'IDが入力されていない場合 MsgBox "IDを入力して下さい", vbExclamation Exit Sub End If Set fRange = Sheets("data").Columns(2).Find(What:=Range("AL1").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) If (fRange Is Nothing) Then 'IDが見つからなかった場合 MsgBox "IDが見つかりません", vbExclamation Exit Sub End If fRow = fRange.row 'IDの行位置を求める Sheets("data").Cells(fRow, 1).Value = Range("AZ1:BE1").Value Sheets("data").Cells(fRow, 2).Value = Range("AL1").Value Sheets("data").Cells(fRow, 3).Value = Range("AA1:AO1").Value Sheets("data").Cells(fRow, 4).Value = Range("D5:E5").Value Sheets("data").Cells(fRow, 5).Value = Range("G5").Value Sheets("data").Cells(fRow, 6).Value = Range("I5").Value Sheets("data").Cells(fRow, 7).Value = Range("D5:F7").Value Sheets("data").Cells(fRow, 8).Value = Range("G6:I7").Value Sheets("data").Cells(fRow, 9).Value = Range("E8:E9").Value Sheets("data").Cells(fRow, 10).Value = Range("G8:G9").Value Sheets("data").Cells(fRow, 11).Value = Range("B11:I24").Value Sheets("data").Cells(fRow, 12).Value = Range("B71").Value Sheets("data").Cells(fRow, 13).Value = Range("C71").Value Sheets("data").Cells(fRow, 14).Value = Range("B73").Value Sheets("data").Cells(fRow, 15).Value = Range("C73").Value Sheets("data").Cells(fRow, 16).Value = Range("B75").Value Sheets("data").Cells(fRow, 17).Value = Range("C75").Value ’・・・・全部でfRow122まであります End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルＶＢＡ オートフィルタの選択を元に戻す
エクセルのＶＢＡで、次のことはできるでしょうか。 ブックの中の３つのシートはオートフィルタが設定してあり、任意で操作し、検索に使っています。（オートフィルタを設定しないしーとが２つあります) ・別のシートにチェンジしたら、チェンジ前のシートがオートフィルタで特定の行だけを表示していたら、オートフィルタを ＜すべて＞ に戻して、消えていた行を全て表示させたいのです。（オートフィルタは次回にまた使うので、データ－フィルタ－オートフィルタでオートフィルタ自体を解除してしまうような状態にはしたくありません） ・同じく、上記のことをブックを閉じるときにも実行したいのです。 ちなみに、オートフィルタをかけてあるシートには、以下のコードがあります。 よろしくお願いします。 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) With Sheets("印刷") .Range("E15:E17").Value = _ Application.Transpose(Cells(Target.Row, 7).Resize(, 3).Value) .Range("AA16").Value = _ Cells(Target.Row, 10).Value .Range("AQ16").Value = _ Cells(Target.Row, 11).Value .Range("AX16").Value = _ Cells(Target.Row, 12).Value End With With Sheets("施設") .Range("C2").Value = _ Cells(Target.Row, 10).Value End With Cancel = True Sheets("施設").Select End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルＶＢＡとmsg関数
こんばんは。 エクセルＶＡＢ初心者です。 現在、エクセル2003で以下の画像のような 表を作成しました。 上段が請求書データ（シート1）で、 下段が請求書の印刷フォーム（シート2）です。 ＶＢＡで実行する処理は、請求書データＮＯをそれぞれ 任意でクリックし、選択しているＮＯの行データをシート2にそれぞれ 転記していき、一括で印刷するものです。 以下のように、コードを作りました。 Sub 発行() Dim i As Range Dim m As Integer Dim W1 As String With Selection W1 = Cells(.Row, 1).Value & " ～ " & _ Cells(.Rows.Count + .Cells(1, 1).Row - 1, 1).Value & vbCrLf & _ " の請求書を発行しますか？" m = MsgBox(W1, vbYesNoCancel) If m <> vbYes Then Exit Sub For Each i In .Resize(, 1) With Sheets("Sheet2") .Range("b1").Value = Cells(i.Row, 1).Value .Range("e1").Value = Cells(i.Row, 2).Value .Range("c5").Value = Cells(i.Row, 3).Value .Range("b3").Value = Cells(i.Row, 4).Value .Range("c6").Value = Cells(i.Row, 5).Value .PrintOut End With Next End With End Sub ここで質問なのですが、"の請求書を発行しますか？" の後に、選択している行の数を（合計Ｏ枚）のように 表示したいのですが、どのようなコードを入れればいいのでしょうか。 また、メッセージボックスのウインドウの中の文字が 小さいので、もう少し大きくしたいのです。 以上の2点ですが、お願いします。
- ベストアンサー
- オフィス系ソフト
- VBAについて質問です。
VBAについて質問です。 まとまったデータがあるところから検索したい月及び各項目のデータを検索し、項目シート事に抽出するという作業を行なっています。そこで問題がでました。6月にはデータはあるが、5月にはデータはない。 そうすると以下のコードの場合デバックが入り、他の検索が出来ません。 どうしたらよいのでしょうか？ 分かる方がいらっしゃいましたらどうかお願い致します。 'シートの変更 Range("B30").Select Sheets("東京").Select '●Sheet2書込み行 Sheets("東京").Range("A5").CurrentRegion.Clear Sheets("東京").Range("A5:F5").Value = _ Array("依頼書No.", "受付日日", "担当者", "枚数", "工数", "備考") Row2 = 5 For R = 2 To Sheets("日報").Cells(Rows.Count, "A").End(xlUp).Row If Sheets("東京").Range("A2") = Sheets("日報").Cells(R, "A") And _ Sheets("東京").Range("B2") = Month(Sheets("日報").Cells(R, "C")) Then Row2 = Row2 + 1 Sheets("東京").Cells(Row2, "A") = Sheets("日報").Cells(R, "B") Sheets("東京").Cells(Row2, "B") = Sheets("日報").Cells(R, "D") Sheets("東京").Cells(Row2, "C") = Sheets("日報").Cells(R, "F") Sheets("東京").Cells(Row2, "D") = Sheets("日報").Cells(R, "I") Sheets("東京").Cells(Row2, "E") = Sheets("日報").Cells(R, "K") Sheets("東京").Cells(Row2, "F") = Sheets("日報").Cells(R, "L") End If Next R '●抽出結果を日付で並べ替え If Row2 = 5 Then MsgBox "該当データなし！" Else Sheets("東京").Range("A5:F" & Row2).Sort _ Key1:=Range("B6"), Order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin End If Sheets("東京").Select Range("B5:B200").Select Selection.NumberFormatLocal = "yyyy/m/d" Rows("5:5").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With このあとに式を入れて、罫線を入れてコピーして、というコードが入っています。 どうぞ宜しくお願い致します。
- ベストアンサー
- その他MS Office製品
- VBAについて
こんばんは、下記のVBAについて質問をさせてください…！ シートの名前と特定の列の名前が一致したらデータを引っ張ってくるというVBAなのですが、下記のVBAではもってくるデータはE列でおわりですが、もっと沢山列がある場合で、例えばDA列とかまである場合はどうすればよいのでしょうか…？！ まさか「.Range("A" & cellCnt).～」というのを一つ一つ入力するわけではないと思うのですが、記述の方法が分からず困っています。 どなたかご教示いただけると大変助かります…！ ' データをとってくるシートの行 Dim dataCnt As Integer ' 貼り付け先のシートの行 Dim cellCnt As Integer cellCnt = 1 For dataCnt = 1 To Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row If Sheets("Sheet1").Range("L" & dataCnt).Value = Sheets(sheetIdx).Name Then With Worksheets(sheetIdx) .Range("A" & cellCnt).Value = Worksheets("Sheet1").Range("A" & dataCnt).Value .Range("B" & cellCnt).Value = Worksheets("Sheet1").Range("B" & dataCnt).Value .Range("C" & cellCnt).Value = Worksheets("Sheet1").Range("C" & dataCnt).Value .Range("D" & cellCnt).Value = Worksheets("Sheet1").Range("D" & dataCnt).Value .Range("E" & cellCnt).Value = Worksheets("Sheet1").Range("E" & dataCnt).Value End With cellCnt = cellCnt + 1 End If Next
- 締切済み
- Excel（エクセル）
補足
ごめんなさい mar00さんとkeithinさんの VBAが混在してしまって、 補足を間違ってしまいました。 申し訳ありません。