• ベストアンサー
※ ChatGPTを利用し、要約された質問です（原文：2つのマクロを1つにしたい）

マクロで複数のシートを印刷し、セルを結合する方法

real beatin（@realbeatin）の回答

  • ベストアンサー
回答No.2

＃１補足欄への返信です。 > ただ、データーのないシートまで印刷プレビューが出るのです。 > A2にデーターがない場合は、飛ばして次のシートへ移動させるには、そうすればいいのか、再度お願いします。 これも元のマクロを踏襲していたのですが、 印刷プレビューについても、"A2にデーターがない場合だけ"、 という風に変更するのでしたら、 ＃１の記述について、 >　　　　End If >　　　　Sh.PrintPr の２行を 　　　　　　Sh.PrintPrevieweview 　　　　End If のように、入れ替えてみたら如何でしょう。 　　　　If Sh.Range("A2").Value <> "" Then 　　　　' ' 「A2にデーターが【ある】場合」の処理 　　　　End If という構造です。

kisaragijec
質問者

お礼

realbeatinさん、ありがとうございました。 希望通りに動きました。 私のコードで、連結はできなかったけれど、印刷プレビューは希望通りに動いていたので、Sh.PrintPrevieweviewの位置はあっているものと思い込んでいました。 先日まで、会社のインターネットが使えなくて、質問等できなかったのですが、これからまたマクロをいろいろ作っていきたいと思っています。 ご教示ください。よろしくお願いいたします。

この回答がついた質問に戻る
回答 全件
どうも^^こんにちは。 > (2)上記のうち、ｃ列のデーターで連続し…
  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. Excel（エクセル）

関連するQ&A

  • マクロで質問します。

    初心者です。 下記のようなマクロの式があるのですが、条件を一つ増やしたいのですが、 イロイロ試してみたのですが、うまくゆきませんので教えてください！ Sub 給与支払一覧() Application.ScreenUpdating = False Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Name <> "給与支払一覧" And Sh.Name Like "Sheet*" Then With Worksheets("給与支払一覧") If Sh.Range("D14").Value > 0 Then With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) Sh.Range("O2:X14").Copy .Cells(1) .Resize(13, 10).Value = Sh.Range("O2:X14").Value End With End If End With End If Next Sh Set Sh = Nothing End Sub この中で　If Sh.Range("D14").Value > 0 Then　とありますが、 同じ条件で　I14も　０より大きいな時としたいのですが、　うまくゆきませんでした。 たぶん基本できな簡単な事と思いますが　分かりません。 If Sh.Range("D14").Value > 0 Then If Sh.Range("I14").Value > 0 Then　並べてみたり If Sh.Range("D14、I14").Value > 0 Then　こんなのや If Sh.Range("D14、I14").).Value > 0 Then　このような事も 他にも笑われるようなことも・・・・・　よろしくお願いします。

  • マクロの式について教えてください！

    マクロの式について教えてください！ 他で使っていたマクロを書き換えて流用してますが、 エラーなどの表示は、出ないのですが、動きません。 考えられる問題を　教えてください。 おねがいします。　下のような式をつかってます。 Sub 給与支払一覧() Application.ScreenUpdating = False Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Name <> "給与支払一覧" And Sh.Name Like "Sheet*" Then With Worksheets("給与支払一覧") If Sh.Range("H5").Value > 0 Then With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) Sh.Range("L1:T5").Copy .Cells(1) .Resize(5, 9).Value = Sh.Range("L1:T5").Value End With End If End With End If Next Sh Set Sh = Nothing End Sub おねがいします。

  • マクロに手を加えたいのですが・・・・・

    マクロに手を加えたいのですが・・・・・ 下記のマクロの式があるのですが、全シートの　ＡＫ８にデーターが０以上だったら 指定の範囲のデーター週払い一覧にコピーしなさいと、　書いてあるのだと おもうのですが・・・　（素人なので、分かりませんが） これだと　１件だけ要らないデーターを読みこんでしまいます。 色んなシート名が有りますが、　欲しいデータのあるシート名は、 必ずSheet番号となっているので、 Sheet１～Sheet５０までのデーターから　（シートNOは、増えたりします） Sheetの名前から　始まる等の指定をしたいのですが、 どのように　書き換えればよろしいでしょうか、 Sub test() Application.ScreenUpdating = False Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Name <> "週払一覧" Then With Worksheets("週払一覧") If Sh.Range("AJ８").Value > 0 Then With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) Sh.Range("AB3:AK8").Copy .Cells(1) .Resize(6, 10).Value = Sh.Range("AB3:AK8").Value End With End If End With End If Next Sh Set Sh = Nothing End Sub 私の勘ですが(笑)　If Sh.Range("AJ８").Value > 0 Thenの IF　Sｈを　If　ｓｈ""　とか　Sh（"　"）　とか　Sh（i）とか＠とか やりましたが　、できませんでした、 初歩的な事でしょうが、　教えてください お願いします。

  • エクセルの簡単なマクロ機能を追加したいのです

    既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です： 　Sheet2のC列に　0　 があれば 　Sheet1のB列に　愛 と（[太字]でセルの背景色を[灰色25%]にして）入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • マクロ修正お願いします。

    以前質問してマクロを作成してもらった者です。 人事データ用に作っていただきました。 Sheet1 　　A　　　B　　　C 1　処遇　コード　名前．．．． 2　退社　　3　　　あ　　 3　異動　　4　　　か　　 4　入社　　20　　　さ　 Sheet2 　　A　　　B　　　　C 1　コード　名前　　データ1．．． 2　　3　　　あ　　　 3　　4　　　か　　　 4　　 Sub testsample() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim r As Range, c As Range Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") For Each c In Sh1.Range("A2", Sh1.Range("A65536").End(xlUp)) Select Case c.Value Case "入社" 　c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A2").End(xlDown).Offset(1) 　'B列より、右端255行を、シート2のA列の最後尾の次にコピーする。 Case "異動" 　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole) 　If Not r Is Nothing Then c.Offset(, 1).Resize(, 255).Copy r 　'コードを検索して、その見つかったものを上書き Case "退社" 　Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole) 　If Not r Is Nothing Then r.EntireRow.Delete 　'コードを検索して、その見つかったものを削除 End Select Next End Sub このマクロで一箇所どーしたらいいか分からない場所があります。 「異動」があった場合、sheet1には氏名コードと新しく配属される部署やtelなどのみを書き、メールアドや氏名など異動しても変わらないものは書き込みません。変更があった箇所のみ上書きし空白部分はそのままにしたいです。何度もすみませんがお願いします。

  • エクセル　マクロ　抽出

    教えてください。 ○と記入されたセルを参照して、一つ上のセル・A列にある同じ行のセル・ 9行目にある同じ列のセルを抽出しようとしています。 下記の通り入力すると　行数＝値.Rowでエラーが出たしまいました。 試行錯誤頑張りましたが解決できそうにありませんのでお力を貸して頂けないでしょうか。 Sub 抽出() Dim i, 行数, 列数 As Long Dim 値 As Range i = 0 行数 = 値.Row 列数 = 値.Column For Each 値 In Sheets("sheet1").Range("C12:R171") If 値.Value = "○" Then i = i + 1 With Sheets("sheet2") .Cells(i, 3).Value = Sheets("sheet1").Cells(行数, 1).Value .Cells(i, 4).Value = Sheets("sheet1").Cells(9, 列数).Value .Cells(i, 5).Value = 値.Offset(-1, 0).Value End With End If Next End Sub

  • エクセル２０１０でマクロが動きません

    こんにちは。 マクロ超初心者です。 頑張ってエクセル２０１６でマクロ作成しましたが、エクセル２０１０で途中から動かず…。 何が悪いんでしょうか… ここから動きません…と書いたところから動きません(涙) Private Sub シート編集_Click() Application.ScreenUpdating = False Dim i Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh4 As Worksheet Set Sh1 = Worksheets("あ") Set Sh2 = Worksheets("い") Set Sh4 = Worksheets("う") Dim dayCutoff As Date dayCutoff = Application.InputBox("年月日を入力してください", "お支払期限 年月日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("D12").Value = DateSerial(Year(dayCutoff), Month(dayCutoff) + 2, 0) 'お支払期限 dayCutoff = Application.InputBox("年月日を入力してください", "請求書発行 日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("AC3").Value = Format(Date, "yyyy/mm/dd") '発行日 Sh1.Cells.Clear With Sh1 'edit .Range("A2") = "番号" .Range("B2") = "会社名" .Range("C2") = "判定" .Range("D2") = "契約番号" .Range("E2") = "拠点" .Range("F2") = "税率" .Range("G2") = "月額(税抜)" .Range("H2") = "消費税" .Range("I2") = "月額(税込)" .Range("J2") = "今回" .Range("K2") = "全回" .Range("L2") = "店番" ここから動きません………… For i = 3 To Sh2.Cells(.Rows.Count, 1).End(xlUp).Row .Cells(i, 1) = Sh2.Cells(i, 2) .Cells(i, 2) = Sh2.Cells(i, 4) .Cells(i, 4) = Sh2.Cells(i, 3) .Cells(i, 5) = Sh2.Cells(i, 4) & "(" & Sh2.Cells(i, 6) & ")" .Cells(i, 6) = Sh2.Cells(i, 9) & "%課税" .Cells(i, 7) = Sh2.Cells(i, 8) .Cells(i, 8) = Sh2.Cells(i, 10) .Cells(i, 9) = Sh2.Cells(i, 11) .Cells(i, 10) = Sh2.Cells(i, 12) .Cells(i, 11) = Sh2.Cells(i, 7) .Cells(i, 12) = Sh2.Cells(i, 2) If Sh1.Cells(i, 10) > Sh1.Cells(i, 11) Then .Cells(i, 3) = "×" Else .Cells(i, 3) = "〇" End If If Sh1.Cells(i, 3) = "×" Then .Cells(i, 2) = "" End If Next i End With '空白行を削除 Dim j As Integer, myFlag As Boolean Dim c As Range With Worksheets("edit").Range("A2").CurrentRegion For j = .Rows.Count To 2 Step -1 myFlag = False For Each c In .Cells(j, 2) If c.Value <> "" Then myFlag = True Exit For End If Next If myFlag = False Then .Rows(j).Delete End If Next End With MsgBox "データの転記が終わりました" End Sub

  • 行方向の同じ値のセルを結合するマクロ

    ネットで色々調べながら、A列方向の同じ値のセルを結合させるマクロ を作ってみたのですが、もっと簡単にできるようでしたら教えていただきたいです。 どうぞよろしくお願いいたします。 Sub セル結合() Dim r As Integer '行数 Dim i As Integer 'カウンタ r = Sheets(1).Range("a1").CurrentRegion.Rows.Count - 1 Application.DisplayAlerts = False For i = 1 To r Cells(i, 1).Activate '項目の一つ下のセルをアクティブに If ActiveCell.Value = ActiveCell.Offset(1).Value Then Range(ActiveCell, ActiveCell.Offset(1)).Merge End If Next Application.DisplayAlerts = True End Sub

  • マクロの質問です。下記の式があるのですが、コピーしたい、セルには、文字

    マクロの質問です。下記の式があるのですが、コピーしたい、セルには、文字や計算式、又は他のセルから参照させてる物もあるので、張り付けたものに、エラーが数多く表示されるのですが、 コピー元の表示されてる文字を　張り付けることは、できるのでしょうか、 よろしくお願いします。 Sub 給与支払一覧() Application.ScreenUpdating = False Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Name <> "給与支払一覧" And Sh.Name Like "Sheet*" Then With Worksheets("給与支払一覧") If Sh.Range("I14").Value > 0 Then With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) Sh.Range("O2:X14").Copy .Cells(1) .Resize(6, 10).Value = Sh.Range("O2:X14").Value End With End If End With End If Next Sh Set Sh = Nothing End Sub

  • マクロで色が同じになるように設定したい

    こんにちは。 現在マクロに挑戦中なのですが、一点分からず戸惑っています。 お分かりになる方教えてください。 下記のマクロを書きました。 Sheet2のセルに数字を入れることによってSheet1のセルの色が変わるようにしています。 25以上の数字は全て青（カラー番号5）表示にしたいのですが、どのように記したら良のか教えてください。 --------------------------------------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) Dim iColors As Variant Dim i As Integer Dim j As Integer iColors = Array(36, 20, 24, 37, 40, 39, 17, 22, 45, 43, 28, 6, 4, 41, 18, 47, 50, 46, 10, 7, 3, 21, 9, 5) For Each c In Target If c.Value <> "" Then If IsNumeric(c.Value) Then i = c.Value If i > 0 And i < 25 Then j = iColors(i - 1) Else j = 2 End If End If End If i = c.Row If i > 2 And j > 0 Then Worksheets("Sheet1").Range("B3:K6").Cells(i - 3).Interior.ColorIndex = j End If Next c End Sub --------------------------------------------------------------- お分かりになる方、宜しくお願い致します。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する
質問する