- ベストアンサー
エクセルマクロで範囲内の空欄を印刷しない方法
- エクセルのマクロを使用して名簿の範囲内にある空欄を印刷しない方法について教えてください。
- 現在、マクロを実行すると名前が空欄の箇所も印刷されてしまいます。
- マクロを実行するたびに範囲を手動で変更する必要があるので、自動的に空欄を印刷しない設定を行いたいです。
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
関連するQ&A
- エクセルのマクロについて
エクセルのマクロについて エクセル2007を使用しています。もしよかったら教えてください。 現在Sheet1のA1:F500の範囲内で1～31範囲の数字がランダムに入力されています。 この数字群の入ったセルをルール化しているセル背景色塗りを自動で処理したいためマクロを作成しております。 その仕様として、もうひとつシート（Sheet2）を作成して（※シート名は”配色表”にしています）、B3:H7範囲に1～31までの数字が入っており、それぞれ数字に背景配色しています。このシート（Sheet2）内の数字とSheet1内と数字が一致したら配色表のセルそのものの書式も運んでくれるルール設計になっています。 （※Sheet1の上記記載している範囲に直接入力及びコピーをして数字がSheet2内と一致したら、色が変わる仕組みになっています。） そのマクロ（※Sheet1内に作成しています）が下記なのですが、拝見頂いて仕様がすぐお分かりになると思います。 Private Sub Worksheet_Change(ByVal Target As Range) Dim v As Variant, c As Range, s As Range Dim rng As Range Set rng = Intersect(Target, Range("A1:F500")) If rng Is Nothing Then Exit Sub Application.ScreenUpdating = False For Each c In rng.Cells For Each s In Worksheets("配色表").Range("B3:H7") v = c.Value If Not IsNumeric(v) Or v < 1 Or v > 31 Then Exit For '色を一旦戻す c.Interior.ColorIndex = xlColorIndexNone c.Font.ColorIndex = xlColorIndexAutomatic If s.Value = v Then c.Interior.ColorIndex = s.Interior.ColorIndex c.Font.ColorIndex = s.Font.ColorIndex Exit For End If Next s Next c Application.ScreenUpdating = True Set rng = Nothing End Sub ここで今回の質問の本題なのですが、このマクロを少し仕様変更して、現在のSheet2の配色表を、A配色表･B配色表･C配色表...というようにJ配色表まで合計10シートまで増やして（※A～Jは全部別々の色に設定する）、更にSheet1に一つH1の場所のセルにA～J迄の英字を入力するためのセルを設けて、例えばそのセルにCを入力すればC配色表を見に行くという条件付きのマクロにしたいと思っております。 これが簡単そうでなかなかうまく行かず困っています。 上記のマクロを使ってどういう風に変更したらベストであるかご伝授頂ければ幸いです。 どうぞよろしくお願い申し上げます。
- ベストアンサー
- オフィス系ソフト
- ＶＢＡ 検索して一致したセルへジャンプさせたい
Excelにて、シート１のＡ列とシート２のＡ列のデータにＮｏを入れます。 シート１のＡ列のＮｏをクリックすると、シート２のＡ列の同じＮｏにジャンプするマクロを組みたいです。 現在組んでいるマクロは、 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Sht As Worksheet Dim Rng1 As Range Dim Rng2 As Range Dim FindCell As Range Set Sht = Worksheets("シート2") Set Rng1 = Range("A2:A100") Set Rng2 = Sht.Range("A2:A100")If Intersect(Target, Rng1) Is Nothing Then Exit Sub If Target.Count > 1 Then Exit Sub Set FindCell = Rng2.Find(Target.Value) If Not FindCell Is Nothing Then Application.Goto Reference:=FindCell, Scroll:=False End If End Sub です。 一応マクロは実行されますが、そうすると、シート１のＡ列の編集（Ｎｏを追加したり変更したり・・・）できません。 編集や変更もできて、検索マクロも実行できるというマクロの組み方はありますでしょうか？
- 締切済み
- その他（プログラミング・開発）
- エクセル マクロの設定方法について
差込印刷でSheet1に作成した名簿データにより、sheet2に作成しているデータへ差込印刷をしています。現在、次のようなマクロを組んで名簿の件数に合わせて、For ＝ 2 To 500 Step 8を修正しながら、印刷しています。できたら、名簿の件数の増減に関係なく印刷できるようになればと考えています。始めたばかりのマクロ初心者です。よろしくご教授ください。お願いします。 Dim i As Long Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 ＝ sheets(″sheet1″) Set ws2 ＝ sheets(″sheet2″) For i ＝ 2 To 500 Step 8 ws2 .Range(″A1″).Value ＝ ws1.Cells(i+1,2).Value ws2 .Range(″A7″).Value ＝ ws1.Cells(i+2,2).Value ws2 .Range(″A13″).Value ＝ ws1.Cells(i+3,2).Value ws2 .Range(″A19″).Value ＝ ws1.Cells(i+4,2).Value ws2 .Range(″F1″).Value ＝ ws1.Cells(i+5,2).Value ws2 .Range(″F7″).Value ＝ ws1.Cells(i+6,2).Value ws2 .Range(″F13″).Value ＝ ws1.Cells(i+7,2).Value ws2 .Range(″F19″).Value ＝ ws1.Cells(i+8,2).Value DoEvents ws2.PrintOut Next End Subws2 .Range(″F1″).Value ＝ ws1.Cells(i+5,2).Value ネット等で調べて、上記のようなマクロで作業してます。（マクロの設定方法が間違っているところがあると思いますが？）
- ベストアンサー
- オフィス系ソフト
- マクロについて
すみません、初心者です。ご教示ください。 今、表中の合計行(表の最終行)の上に、行を挿入するマクロを作成しておりまして。 【コマンドボタンを押すと、ウィンドウが出てきて、挿入したい行数を入力すれば、その分だけ挿入される】 Sub 表の行挿入() Dim r2 As Long Dim r As Long Dim rge As Range A列に合計欄があることが前提 Set rge = ActiveSheet.Range("A:A").Find("計") if rge Is Nothing Then Exit Sub r = rge.Row r2 = TextBox1.Text If r2 > 0 Then ActiveSheet.Range("A" & r & ":F" & (r + r2 - 1)).Insert xlDown ・・・ とここまで記述して、なやんでいます。 表はこの場合A列からF列までの範囲のものなのですが、 上記AやFという記述ではなく、マクロにて表の範囲指定を、うまくできないかな、と。 よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- エクセルのマクロについて教えてください
お世話になっております。 エクセルのマクロについて教えていただきたいのですが、 サンプルのファイルをこちらにアップしたのでよろしければご覧になってください。 http://kie.nu/yPV 質問したいことは、列Iに、各行の黄色いセルの数を表示させるマクロを作りたいのですが 途中まで何とかわかったのですがどうもうまくいきません。。 行11から各行にひとつずつ、黄色いセルが含まれていますが、その黄色いセルの中の数字を列Iに表示させたいです。行にデータがある限り、下までずっとです。 以下、途中までわかったマクロです。 Sub 黄セル値Copy() Const TgLeftUp = "A3" '<--対象範囲左上セル指定 Dim Rng As Range Dim Target As Range Set Target = Range(TgLeftUp, Cells(Rows.Count, _ Range(TgLeftUp).Column)) For Each Rng In Target.Resize(, 2) If Rng.Interior.ColorIndex = 6 Then If Rng.Column = Target.Column Then Rng.Offset(, 3).Value = Rng.Value Else Rng.Offset(, 2).Value = Rng.Value End If End If Next MsgBox "値 貼り付け完了。", vbInformation Set Target = Nothing End Sub でもこれを貼り付けてもうまくいきません。 正しいマクロを教えていただけないでしょうか？？ 宜しくお願いいたします。 ※いつも、私の質問に対してまるで回答になってないような、ふざけた言葉を書き込んでは消してる方が一名だけいらっしゃいます。確か、鳥の写真をマイページに載せてる方です。 都度違反報告はしていますが、質問の趣旨に反する回答をされてる方一名、絶対にやめてください。
- ベストアンサー
- その他MS Office製品
- エクセルVBAのオートフィルタについて
いつもお世話になります。 エクセル2007でVBAでオートフィルタを操作したいのですが、 一部うまくいきません。 以下の様なコードを書いて 日付で絞り込みたいのですが、 何も抽出されません。 リストを見てみると、変数はちゃんと入っており OK ボタンを押すとその日付で抽出されます。 何故VBAでの操作では抽出されないのでしょうか。 ご存じの方がおられましたら、よろしくお願いします。 Sub test() Dim mydate As Variant Dim rng3 As Range Dim fmt As Variant Dim objList3 As ListObject Dim wb1 As Workbook Dim wb2 As Workbook Dim wb4 As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet Dim sh4 As Worksheet Dim sh7 As Worksheet '----------------------------------------------------------------------- Set wb1 = Workbooks("301.xlsm") Set wb2 = Workbooks("1.xls") Set wb4 = Workbooks("2.xls") Set sh1 = wb1.Worksheets("@") Set sh2 = wb1.Worksheets("@@") Set sh3 = wb2.Worksheets("@@@") Set sh4 = wb2.Worksheets("@@@@") Set sh7 = wb4.Worksheets("@@@@@") '---------------------------------------------------------- sh2.Range("A1:z63").ClearContents With sh7 Set objList3 = .ListObjects("リスト1") fmt = .Range("A2").NumberFormatLocal mydate = Format(mydate, fmt) objList3.Range.AutoFilter Field:=7, Criteria1:=mydate objList3.Range.AutoFilter Field:=5, Criteria1:="test" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A2") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=5, Criteria1:=">=190" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A20") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=7 End With Application.CutCopyMode = False Set rng3 = Nothing Set fmt = Nothing Set objList3 = Nothing Set wb1 = Nothing Set wb2 = Nothing Set wb4 = Nothing Set sh1 = Nothing Set sh2 = Nothing Set sh3 = Nothing Set sh4 = Nothing Set sh7 = Nothing End Sub （一部省略しています）
- ベストアンサー
- その他MS Office製品
- 既存のエクセルマクロに命令文を追加
既存のマクロに別の命令文を追加する場合について質問です。 選択した範囲のオブジェクトを削除するマクロがあります。 下の命令文に 「シート2でも同じことをする（ただし選択範囲はC30からG33）」 を追加する場合には、どのように書けばいいのでしょうか？ Sheets("シート1").Select Range("A65:E365").Select Dim shp As Shape Dim rng_shp As Range 'セルが選択されていないときは終了 If TypeName(Selection) <> "Range" Then Exit Sub 'アクティブシートのすべての図形にループ処理 For Each shp In ActiveSheet.Shapes '図形の配置されているセル範囲をオブジェクト変数にセット Set rng_shp = Range(shp.TopLeftCell, shp.BottomRightCell) '図形の配置されているセル範囲と '選択されているセル範囲が重なっていれば図形を削除 If Not Intersect(rng_shp, Selection) Is Nothing Then shp.Delete End If Next Sheets("シート0").Select Range("A1").Select 同じものを上記命令文の下にコピーして選択シートと範囲を直すだけだと、 Dim shp As ShapeとDim rng_shp As Rangeがエラーになります。 どなたかご教示お願いします。
- 締切済み
- その他（ビジネス・キャリア）
- エクセルマクロで教えてください
Sub smp05_14_01() Dim 対象セル As Range Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim 行 As Long, 列 As Long Dim i As Long Set ws1 = Worksheets("顧客") Set ws2 = Worksheets("売上") Set ws3 = Worksheets("顧客未登録") 行 = ws1.Range("A1").End(xlDown).Row - 1 列 = ws1.Range("A1").End(xlToRight).Column Set 対象セル = ws1.Cells(1, 列 + 2).Resize(2, 行) For i = 1 To 行 対象セル(1, i).Value = "顧客NO" 対象セル(2, i).Value = "<>" & ws1.Cells(i + 1, 1) Next ws2.Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=対象セル, _ CopyToRange:=ws3.Range("A1") 対象セル.Clear End Sub 上記のマクロは売上のシートに登録されている以外の顧客NOを顧客シートを参照して顧客未登録シートにコピーするのもですが添付したファイルの数だと上手くいくのですが、エクセルのヨコのセルの最大値の258を越えると上手くいきません。上記の処理で1000レコードを越えても売上シートに登録されている以外の顧客NOを参照して顧客未登録シートにコピーするマクロを教えてください。
- 締切済み
- オフィス系ソフト
- エクセルのマクロについて
エクセルのマクロについて エクセル2007を使用しています。もしよかったら教えて頂きたいと思っております。 現在利用しているメインシート(Sheet16で認識)のD5:I500の範囲内で1～31範囲の数字がランダムに入力されています。 この数字群の入ったセルをルール化しているセル背景色塗りを自動で処理したいためマクロを作成しております。 その仕様として、10個のシート（シート名：Aセット配色～Jセット配色）を作成して、各シートのB3:H7範囲に1～31までの数字が入っており、それぞれ数字に背景配色しています。Sheet16内と数字と条件によって該当する10個のシート内（シート名：Aセット配色～Jセット配色）の中から1つのシートとが一致したらそのセット配色シートのセルそのものの書式も運んでくれるルール設計になっています。 （※Sheet16の上記記載している範囲に直接入力及びコピーをして数字が一致したら、色が変わる仕組みになっています。） 更に、Sheet16内のJ3セルにA～J迄の半角英字を入力規制セットしており、例えばそのセルにCを入力すればCセット配色（シート名）、A入力であればAセット配色（シート名）を見に行き、該当処理をして行くという仕様になっております。 そのマクロ（※げＮSheet16内に作成しています）が下記なのですが、拝見頂いて仕様がすぐお分かりになると思いますが、、 Private Sub Worksheet_Change(ByVal Target As Range) Dim v As Variant, c As Range, s As Range, myStr As String Dim rng As Range Set rng = Intersect(Target, Range("D5:I500")) If rng Is Nothing Then Exit Sub If Range("J3").Value = "" Then MsgBox "セット配色が未設定です。", vbCritical, "セットエラー " Exit Sub End If myStr = Range("J3").Value & "セット配色" Application.ScreenUpdating = False For Each c In rng.Cells For Each s In Worksheets(myStr).Range("B3:H7") v = c.Value If Not IsNumeric(v) Or v < 1 Or v > 31 Then Exit For c.Interior.ColorIndex = xlColorIndexNone c.Font.ColorIndex = xlColorIndexAutomatic If s.Value = v Then c.Interior.ColorIndex = s.Interior.ColorIndex c.Font.ColorIndex = s.Font.ColorIndex Exit For End If Next s Next c Application.ScreenUpdating = True Set rng = Nothing End Sub 今回の質問内容は、このマクロを少し仕様変更して、 C4：C500範囲でデータ書換えがあった場合にその瞬間、現行のJ3セルにその入力した英字と同じ値を表示させ次の処理に移行する方法にて上手くいかないかなと思っております。 上記のマクロを使用して追加組み込みをする前提で考えると、どういうコードを追加すれば実現出来ますでしょうか？ どうかご伝授頂けますと幸いです。 よろしくお願い申しあげます。
- ベストアンサー
- オフィス系ソフト
- エクセル 2010 マクロ 検索
http://okwave.jp/qa/q8562170.html 上記質問に追加です。 ※1 'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時 E,F,G,H,Iのいずれかだったら左横列の上に向かって (EならD 、FならE ・・・という具合に) 何か入力されているセルのM列の191000####をmsgboxで表示させたいです。 (画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、 その行のM列のセル(191000####)をmsgboxで表示 ※2 但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合 M列の191000####をmsgboxで表示させたいです。 (画 D25セル(Y-1)対象の時) ※3 また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合 (空白だったり191000####以外の場合) M列の一番上の191000####をmsgboxで 191000####&「これは例外です」と表示させたいです。 (画 D24セル (X-1)対象の時) 現在のコードは下記のとおりです。 Sheet1に Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Call 検索 Range("A1:A2").Clear Range("A1").Activate End Sub 標準モジュールに Sub 検索() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim strKey As Variant Dim s As String Dim c As Range, bln As Boolean Dim rng1 As Range Dim cnt As Long Set Ws1 = Sheet1 Set Ws2 = Sheet2 Ws1.Select With Ws2 strKey = Application.Transpose(.Range("A1").Resize(2).Value) strKey = Join(strKey, "") End With If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub With Ws1 Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp)) For Each c In rng1.Offset(, -10) 'D,E,F,G,H,I,Kを検索 s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value & If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then c.End(xlToRight).Activate c.Offset(0, 2).Value = Date c.Resize(1, 14).Interior.ColorIndex = 6 bln = True Exit For End If Next c If Not bln Then Ws2.Select MsgBox "リストに存在しません", vbExclamation, "NotFound" Else '加える Call ReSearch(Ws1.Range("M2"), c.Row) '再設定 Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp)) MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation End If End With Application.Goto Ws2.Range("A1"), True End Sub Sub ReSearch(Rng As Range, j As Long) '最初のセル, 終わりの行数 Dim i As Long Dim Ws As Worksheet With Rng.Parent For i = j To Rng.Row Step -1 If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です" Exit For End If Next i End With End Sub Function DoubleCountBlank(rng1 As Range, rng2 As Range) '横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2) Dim i As Long Dim cnt As Long For i = 1 To rng1.Rows.Count If VarType(rng2.Cells(i, 1)) = vbDouble Then If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then cnt = cnt + 1 End If End If Next i DoubleCountBlank = cnt End Function 宜しくお願い致します。
- ベストアンサー
- Excel（エクセル）
お礼
早々のご回答ありがとうございます。 バッチリうまくいきました。 感動です！！