- ベストアンサー
マクロに手を加えたいのですが・・・・・
- 下記のマクロの式があるのですが、全シートのＡＫ８にデーターが０以上だったら指定の範囲のデーター週払い一覧にコピーしなさいと、おもうのですが・・・これだと１件だけ要らないデーターを読みこんでしまいます。色んなシート名が有りますが、欲しいデータのあるシート名は、必ずSheet番号となっているので、Sheet１～Sheet５０までのデーターからSheetの名前から始まる等の指定をしたいのですが、どのように書き換えればよろしいでしょうか
- この質問は、マクロの変更に関するものです。現在のマクロは、全シートのＡＫ８にデータが0以上ある場合、指定の範囲のデータを週払い一覧にコピーする仕様です。ただし、このままでは1件だけ不要なデータを読み込んでしまいます。質問者は、シート名がSheetで始まる50枚のシートからデータを取得したいと考えています。書き換える方法を教えて欲しいとのことです。
- 質問者はマクロの変更について相談しています。現在のマクロは、全シートのＡＫ８にデータが0以上ある場合、指定の範囲のデータを週払い一覧にコピーする処理を行っています。しかし、これでは1件だけ不要なデータを読み込んでしまいます。質問者は、Sheetで始まる50枚のシートからデータを取得するようにマクロを書き換えたいと考えています。書き換える方法を教えて欲しいとのことです。
- YOMOGI（@07535373）
- お礼率61% (60/98)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
関連する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 おねがいします。
- ベストアンサー
- オフィス系ソフト
- マクロの質問です。下記の式があるのですが、コピーしたい、セルには、文字
マクロの質問です。下記の式があるのですが、コピーしたい、セルには、文字や計算式、又は他のセルから参照させてる物もあるので、張り付けたものに、エラーが数多く表示されるのですが、 コピー元の表示されてる文字を 張り付けることは、できるのでしょうか、 よろしくお願いします。 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
- ベストアンサー
- オフィス系ソフト
- エクセル２０１０でマクロが動きません
こんにちは。 マクロ超初心者です。 頑張ってエクセル２０１６でマクロ作成しましたが、エクセル２０１０で途中から動かず…。 何が悪いんでしょうか… ここから動きません…と書いたところから動きません(涙) 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
- 締切済み
- Visual Basic
- エクセル マクロ 教えてください。
sheet１に （a1=No. b1=月日 C1=項目 d1=収入 e1=支出 f1=摘要 G1=店名）項目を作りそれらをユーザーフォームを作り入力したいです。 この記述では上手く動けません。教えてください。 Private Sub CommandButton1_Click() Dim r As Long, 最終行 As Long, 項目行 As Long Dim re As String r = textboxs1.Value + 10 最終行 = Worksheets("入力").Range("B65536").End(xlUp).Row If r <= 最終行 Then re = MsgBox("訂正" & " " & "すでにデータが入力されています。" & Chr(13) & _ Chr(13) & "データを置き換えます。 本当に良いですか? ", _ Buttons:=vbYesNo + vbExclamation, Title:="注意!!") If re = vbYes Then With Worksheets("入力") .Cells(r, 2).Activate .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = ComboBox2.Value End With データクリア Exit Sub End If データクリア Exit Sub End If If r >= 最終行 + 1 Then r = 最終行 + 1 End If With Worksheets("入力") .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = CBomboox2.Value End With データクリア End Sub r = データNo + 10 With Worksheets("入力") .Activate .Cells(r, 2).Select TBox1.Value = .Cells(r, 1).Value TBox2.Value = .Cells(r, 2).Value ComboBox1.Value = .Cells(r, 3).Value TBox3.Value = Format(.Cells(r, 4).Value, "###,###") TBox4.Value = Format(.Cells(r, 5).Value, "###,###") TBox5.Value = .Cells(r, 6).Value ComboBox2.Value = .Cells(r, 7).Value End With Exit Sub End If If データNo > 最終行 - 10 Then データNo = 最終行 - 9 TBoxNo.Value = データNo データクリア End If End Sub
- ベストアンサー
- オフィス系ソフト
- DTPickerで入力したらの検索が出来なくなりました。
お世話になります。 質問ですが 以下のVBAコードがあります。Sheet3のCells(2, 6)に記入した日付によってSheet1の検索を一部行うのですが、Cells(2, 6)への入力をDTPickerを使って行うようにしたら該当する日付がありませんのエラーが帰ってきます。たぶん書式が違うせいかなと思うのですがどうすればいいのでしょうか？ どなたか分かる方いらっしゃいますか？よろしくお願いします。 Private Sub CommandButton1_Click() Dim trgA As Variant, trgB As Variant With Worksheets("Sheet3") If IsEmpty(.Cells(2, 7)) Then MsgBox "個数が空です。", vbCritical: Exit Sub '日付 trgA = Application.Match(.Cells(2, 6).Value2, Worksheets("Sheet1").Range("A:A"), 0) If IsError(trgA) Then MsgBox "該当する日付がありません。", vbCritical: Exit Sub '製品名 trgB = Application.Match(.Cells(2, 4).Value, Worksheets("Sheet1").Range("2:2"), 0) If IsError(trgB) Then MsgBox "該当する製品名がありません。", vbCritical: Exit Sub If Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = "" Then Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = .Cells(2, 7).Value Else If MsgBox("上書きしますか", vbQuestion + vbOKCancel) = vbOK Then Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = .Cells(2, 7).Value End If End If End With End Sub
- 締切済み
- オフィス系ソフト
- ファイルオープン時のマクロが一部実行されない
いつも回答して頂き、ありがとうございます。感謝感謝です。 ファイルオープン時にApplication.Runで３つのマクロを実行させているのですが、最後のマクロだけ実行されません。どうしてでしょうか？もしかして、前の２つで『一覧シート』を除外するマクロを実行しているからでしょうか？御指導の程宜しくお願いいたします。 1番目に実行するマクロ Sub 特定のシート以外の最終履歴と次回予定日を算出する() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Integer c = 3 Do While ws.Cells(2, c).Value <> "" With ws.Cells(6, c) .FormulaR1C1 = "=MAX(R8C:R10000C)" If .Value = 0 Then .Value = "履歴無し" ws.Cells(7, c).ClearContents Else .Value = .Value ws.Cells(7, c) = DateAdd("d", ws.Cells(5, c), DateAdd("m", ws.Cells(4, c), DateAdd("yyyy", ws.Cells(3, c), ws.Cells(6, c)))) End If End With c = c + 1 Loop End If End If Next End Sub ２番目に実行するマクロ Sub 期限の未達と到達を色で分ける() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Long Dim res As Variant For c = 3 To ws.Cells(7, Columns.Count).End(xlToLeft).Column If IsDate(ws.Cells(7, c)) Then If ws.Cells(7, c) > Date Then res = 8 Else res = 3 End If Else res = xlNone End If ws.Cells(7, c).Interior.ColorIndex = res Next c End If End If Next End Sub ３番目に実行するマクロ Sub 各シートの情報を一覧へ転記する() Dim d As Integer Dim retu As Integer d = 3 Do While Cells(d, 2).Value <> "" With Worksheets(Worksheets("一覧").Cells(d, 2).Value) .Activate retu = .Range("IV7").End(xlToLeft).Column .Range(Cells(7, 3), Cells(7, retu)).Copy End With With Worksheets("一覧") .Activate Cells(d, 3).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End With d = d + 1 Loop End Sub
- ベストアンサー
- オフィス系ソフト
- 2つのマクロを1つにしたい
いつもお世話になっております。 今回もよろしくお願いいたします。 (1)14のシートがあるのですが、データーのある2から14までのシートを印刷する。 (2)上記のうち、ｃ列のデーターで連続しているセルを結合する。 (1)と(2)を合わせて1つのマクロにしたいのですが、アクティブシート１つにしか(2)のマクロが動きません。 下記のコードの間違いを教えてください。 Sub 契約書目次印刷() Dim Sh As Worksheet Dim t As Long Dim i As Range t = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'データーのあるシートだけ印刷 For Each Sh In Worksheets(Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)) If Sh.Range("A2").Value <> "" Then '連続データーセル結合 For Each i In Range("C1:C" & t) If i.MergeArea(1).Value = i.Offset(1).Value Then Range(i.MergeArea, i.Offset(1)).Merge End If Application.DisplayAlerts = False Next i End If Sh.PrintPreview Next Sh End Sub
- ベストアンサー
- Excel（エクセル）
- このマクロを少し修正したい
先日、こちらのサイトで下記のマクロを作っていただきました。 エクセルの置換えシートを使って、別のエクセルシートを一括置換えするマクロです。 ただ、置換えしたいシートのセルが結合していたり、文字の前に空欄が入っていると変換されません。 上記も認識しての置換えは、下記のマクロを修正して可能でしょうか？ 修正したマクロを教えていただけると助かります。 With ThisWorkbook If ActiveSheet Is .Worksheets(1) Then Exit Sub For i = 1 To .Worksheets(1).Range("A65536").End(xlUp).Row ActiveSheet.Cells.Replace _ What:=.Worksheets(1).Range("A" & i).Value, _ Replacement:=.Worksheets(1).Range("B" & i).Value, _ LookAt:=xlPart, SearchOrder:=xlByColumns Next End With End Sub
- ベストアンサー
- その他(ソフトウェア)
- マクロ FIND 検索方向の変更
いつも回答ありがとうございます。 FINDを使用した検索方向の変更についての質問です。以下のFINDの記述方法で、上から一発目に捉えられたキーワードではなく、下から一発目に捉えられたキーワードに変更するにはどうしたらよろしいでしょうか？それとも、FINDの記述方法を大幅に変えなければいけないのでしょうか？御指導の程宜しくお願い致します。 Sub TEST() Dim d As Integer Dim e As Integer Worksheets("一覧").Activate d = 3 e = 3 Do While Worksheets("一覧").Cells(d, 2).Value <> "" Dim c As Variant Dim R As Range Dim s As Range With Worksheets(Worksheets("一覧").Cells(d, 2).Value) Set c = .Columns("H").Find("増", , xlValues, 1) If Not c Is Nothing Then Set R = .Range(c.Offset(1, -4), .Cells(Rows.Count, "D").End(xlUp)) Set s = c.Offset(, -5) With Worksheets("編集用一覧") .Range(.Cells(e, 4), .Cells(e, 5)).ClearContents .Cells(e, 4).Value = s .Cells(e, 5).Value = Application.Sum(R) End With End If End With d = d + 1 e = e + 4 Loop End Sub
- ベストアンサー
- オフィス系ソフト
お礼
ありがとうございます。 上手く出来ました。 たすかりました。