• 締切済み
  • 困ってます

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

既存のエクセルマクロ(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

共感・応援の気持ちを伝えよう!

  • 回答数1
  • 閲覧数85
  • ありがとう数1

みんなの回答

  • 回答No.1
noname#158634

>Sheet2のC列に 0  があれば Ifを使う。 >([太字]でセルの背景色を[灰色25%]にして) 太字はFont.Bold、背景色はInterior.Color(もしくはColorIndex)です。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

お礼の返事が遅れて申し訳ありませんでした。 返答頂きましてありがとうございました。 エクセルのマクロのホームページを見て試行錯誤していたのですが、エラーが出てしまいましてできませんでした。 このマクロプログラムでどのようにすればできるか教えていただければ幸いです。 よろしくお願いいたします。

関連するQ&A

  • カットして隣のB列に順番にペーストするマクロ

    発注と納品の確認マクロを作成しました。 Sheet1の列を検索して、Sheet2にあればその数字のあるセルを赤くするのですが、 それを以下のように変更することは可能でしょうか? Sheet1の列を検索して、Sheet2にあれば、Sheet2上でその数字をカットして隣のB列に上から順番にペーストします。 宜しくお願いします。 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 myCt = 0 Then c2.Interior.ColorIndex = 3 Else c2.Interior.ColorIndex = 43 End If myCt = myCt + 1 End If Next c2 If myCt = 0 Then c1.Interior.ColorIndex = 6 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • エクセル マクロ修正

    シート1~5まであります。別に情報シートを作成しています それぞれ同じ原本から作成しています 全部のシートにA1~A10のセルに日付、B1~B10のセルに文字など入力がするところがあります 入力はA1から順番に入れていきます 例えば 保存ボタンを作成しておく シート1のA1に日付、B1に”文字”を入力し、保存ボタンをおす 情報シートに日付と内容が一致する情報がなければ、 情報シートのA列にシート名、B列に日付、C列に入力した内容が 空白のところに出力される ボタンのマクロがCommandButton1_Clickとしたら Private Sub CommandButton1_Click() 検索 End Sub 標準モジュールに Sub 検索() Dim c As Range Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws1LastRow As Long Dim ws2LastRow As Long Set ws1 = Sheets("情報シート") Set ws2 = ActiveSheet If ws2.Range("A1").Value = "" Or ws2.Range("B1").Value = "" Then MsgBox "検索する日付もしくは語句が入力されていません。", vbCritical Exit Sub End If If ws1.Range("A1").Value = "" Then ws1LastRow = 0 Else ws1LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row End If ws2LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row For Each c In ws1.Range(ws1.Cells(1, "B"), ws1.Cells(Rows.Count, "B").End(xlUp)) If c.Value2 = ws2.Cells(ws2LastRow, "A").Value2 Then If c.Offset(0, 1).Value = ws2.Cells(ws2LastRow, "B").Value Then MsgBox "既にデータが存在します", vbInformation Exit Sub End If End If Next ws1.Cells(ws1LastRow + 1, "A").Value = ws2.Name ws1.Cells(ws1LastRow + 1, "B").Resize(1, 2).Value = ws2.Cells(ws2LastRow, "A").Resize(1, 2).Value MsgBox "データを追加しました", vbInformation Set ws1 = Nothing Set ws2 = Nothing End Sub これを教えて頂き作っていたのですが 別のシートを作成しこのプログラムを応用していたのですが うまく起動しないため再度投稿しました 今度のやつは固定でやろうと思っていていじったのですが 別の欄の文字が表示してしまった 結合セルB2:C4に日付を入れる 結合セルL2:L30に内容を入れるようにしたいのですが ここだけのセルを参照するようにしたいのです。 どうすればいいでしょうか? 試したことAをB2にかえ、BをL2にしたら変なことになりました・・・

  • エクセル 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 宜しくお願い致します。

  • エクセルでマクロの進行状況を表示あるには

    下記のマクロはURLからタイトルを抽出するものなのですが 件数が何千件とあり、進行状況が分かれば便利かなと思います。 表示方法はどのような形でも構わないのですが、ご教授願います。 色々調べたのですがうまくいかず困っております。 ちなみに私は全くの度素人であり、マクロもネット上で検索して 見つけたものをそのまま使用しております。 ------------------------------- Private Sub CommandButton1_Click() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A2") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send With CreateObject("ADODB.Stream") .Open .Type = 2 'adTypeText .Charset = "unicode" .Writetext Http.ResponseBody .Position = 0 .Charset = "utf-8" buf = .ReadText() .Close End With 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function Private Sub タイトル抽出_Click() End Sub ------------------------------ 宜しくお願い致します。

  • マクロが動作しない

    Office2003にバージョンアップすると動作しないマクロが出ました。ちゃんと動作するものもあります。 内容は変更していないので内容はあってるはずですが 念のためコピーします。 Sub 電装品() Dim Gyou As Integer Dim Gyouz As Integer Dim State As Integer Dim Statez As Integer Dim CelValue As String Dim CelValuez As String Dim CopyCelNo As String Dim CopyCelNoz As String Dim WS1 As Object Dim WS2 As Object Set WS1 = Worksheets("購入品リスト") Set WS2 = Worksheets("電装品リスト") WS2.Range("A:G").Delete Shift:=xlToLeft WS2.Range("B1") = "電 装 品 リ ス ト" With WS2.Range("B1") .Font.Bold = True .Font.Italic = True .Font.Size = 24 End With WS2.Range("D1") = "作成日:" & Date WS1.Range("C3:E3").Copy (WS2.Range("A2:C2")) State = 3 For Gyou = 1 To 2000 CopyCelNo = "A" & State CelValue = WS1.Cells(Gyou, 17).Value If CelValue = "1" Then WS1.Range(WS1.Cells(Gyou, 3), WS1.Cells(Gyou, 5)).Copy (WS2.Range (CopyCelNo)) State = State + 1 End If Next WS1.Range("G3:J3").Copy (WS2.Range("D2:G2")) Statez = 3 For Gyouz = 1 To 2000 CopyCelNoz = "D" & Statez CelValuez = WS1.Cells(Gyouz, 18).Value If CelValuez = "1" Then WS1.Range(WS1.Cells(Gyouz, 7), WS1.Cells(Gyouz, 10)).Copy (WS2.Range (CopyCelNoz)) Statez = Statez + 1 End If Next End Sub

  • 複数のエクセルシートをまとめるマクロ

    下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") 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 ネット等で調べて、上記のようなマクロで作業してます。(マクロの設定方法が間違っているところがあると思いますが?)

  • Excelの目次作成のマクロ

    Excel 2000 で本の目次を作りたいと、思いネットで下記ののようなマクロを見つけました。 Sub 索引作成()   Dim R As Range, R2 As Range, LastFound As Range   Dim Found As Boolean   Range("C2", Range("D65536").End(xlUp).Offset(1, 0)).Clear   For Each R In Range("A2", Range("A65536").End(xlUp))     Found = False     Set LastFound = Range("C65536").End(xlUp)     For Each R2 In Range("C2", LastFound)       If R2.Value = R.Value Then         R2.Offset(0, 1).Value = R2.Offset(0, 1).Value & "," & R.Offset(0, 1).Value         Found = True       End If     Next     If Found = False Then       LastFound.Offset(1, 0) = R.Value       LastFound.Offset(1, 1) = R.Offset(0, 1).Value     End If   Next End Sub このマクロを使うと下記のような結果になるのですが、頁数の桁が多い場合(1000ページ以上)や、項目名の重複が多い場合は上手く動きません。  A    B    C    D 項目名  頁 A     1 B     2 C     3 D     4 A     5 B     6 C     7 D     8   ↓上記マクロを使うと  A    B    C    D 項目名  頁 A     1    A    1,5 B     2    B    2,6 C     3    C    3,7 D     4    D    4,8 A     5 B     6 C     7 D     8 となりますが、頁が1000桁以上になると A B      C     D 項目名  頁 A     1000    A    100,010,04 B     1001    B    100,110,05 C     1002    C    100,210,06 D     1003    D    100,310,07 A     1004 B     1005 C     1006 D     1007 のようになります。 頁が1000桁以上になる場合や、項目名の重複が多くなる場合でも上手く動くマクロは無いものでしょうか。 何卒、宜しくお願いいたします。

  • エクセルで在庫表を作ろうとしています

    エクセルで在庫表を作ろうとしているのですが、躓いてしまって困っています。 TEST1 コードを手入力した後実行 TEST2 出庫数を入力した後実行 Option Explicit Option Base 1 Sub TEST1() 'コードを手入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL1 As String Dim vL2 As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r vL1 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 2, False) ws1.Cells(i, 1).Offset(, 1) = vL1 vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 3, False) ws1.Cells(i, 1).Offset(, 2) = vL2 Next i End Sub Sub TEST2() '出庫数を入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL2 As Long Dim vL3 As String Dim syukko As Long Dim fnd As Range Dim zaiko As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r If ws1.Cells(i, 4) > 0 Then syukko = ws1.Cells(4, 1).Offset(, 3).Value vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(3, 2), ws2.Range("A2:IV65536"), 3, False) Set fnd = ws2.Range("A:A").Find(ws1.Cells(i, 1)) If fnd Is Nothing = False Then zaiko = vL2 - syukko fnd.Offset(, 2) = zaiko End If MsgBox ws1.Cells(i, 2) & "を" & syukko & "出庫します" & vbLf & "在庫は" & zaiko & "になります。" Else MsgBox "出庫数を入力して下さい" Exit Sub End If Next i ws1.Range("A2:D65536").ClearContents End Sub ここまでは作りました。 ですが、プロシージャの外では無効です と出てしまいます。 どうすればよいのでしょうか。 教えて下さい。 シート1のB2にコード・C3に名前・D2に現在個数・E2に出庫数を入力します。 実際にはB3からすうじを入力し、コードを入力すれば自然に名前と現在個数を シート2から探してくるようにしたいです。 シート2にはA列にコード、B列に名前、C列に現在庫数が載っている表があります(量が半端ではないです) 出来れば、1度出庫数を入れたら、次開いた時にシート2のC列にある現在個数が自然に減っていて、シート1にはフォームしか残らない状態にしたいです。 お願いします<m(__)m>

  • エクセルでURLからタイトルのみを抽出する方法

    URLからタイトルを抽出するマクロについて教えて下さい。 忍者ブログの記事タイトルをURLから抽出しようとしたのですが 文字化けしてしまい全く分かりません。 他のサイトやブログだと普通に抽出出来るのですが・・・ 文字コード?か何かだと思うのですが、原因が分かりません。 ちなみに以下のマクロは、ネット上で検索して見つけたものを そのままコピーして使用しています。 ------------------------------- Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A3") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function ------------------------------ 宜しくお願い致します。