• ベストアンサー
  • すぐに回答を!

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

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

  • 回答数3
  • 閲覧数191
  • ありがとう数3

質問者が選んだベストアンサー

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

こんにちは。 Ws2 のA1 とA2 だけを使うというのでしたら、検索方法を変更しました。 以下は、十分にチェックなされていませんので、不具合がありましたら、教えてください。 自分で試した分には、なんとなく、メッセージが何度も出てきて、しっくりきません。 本来は、まとめて出たほうが良いかもしれません。 「私のアレンジ」という部分は、既に検索したものを表示するためのものです。 コメントブロックを外せばメッセージが出ますが、不要なら削除してしまっても良いです。 '// Sub 検索()  'ver.0.3 '2014/05/01  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 '* Ws2 の画面に時に、Ws1に戻します。    With Ws2   strKey = Trim(.Range("A1").Value) & "," & .Range("A2").Value '*    'Application.Transpose(.Range("A1").Resize(2).Value)    'strKey = Join(strKey, "")  End With    If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub    With Ws1   .Select   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 Then     If c.Offset(0, 2).Value = "" Then '変更を加えた      c.Offset(0, 2).Value = Date      c.Resize(1, 14).Interior.ColorIndex = 6      bln = True      If c.Offset(, 2).End(xlToRight).Value <> "" Then '右に検索       Call NumberSearch(c.Offset(, 2).End(xlToRight)) '*番号探し2      End If      Exit For     Else      '私のアレンジ      'MsgBox "コードは見つかりましたが、日付が既に入っています。 " & c.Offset(0, 2).Text, vbExclamation     End If    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 NumberSearch(r As Range) '2014/05/01 Dim i As Long If r.Column = 4 Then   If Cells(r.Row, 13).Value Like "191000####" Then    For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row      If Cells(i, "M").Value Like "191000####" Then        Cells(i, "M").Select        MsgBox Cells(i, "M").Value, vbInformation        Exit For      End If    Next i   ElseIf Not Cells(r.Row, 13).Value Like "191000####" Then     For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row      If Cells(i, "M").Value Like "191000####" Then        Cells(i, "M").Select        MsgBox Cells(i, "M").Value & "これは例外です", vbExclamation        Exit For      End If    Next i   End If Else   For i = r.Row To 2 Step -1      If Cells(i, "M").Value Like "191000####" Then        Cells(i, "M").Select        MsgBox Cells(i, "M").Value, vbInformation        Exit For      End If        Next i End If End Sub 前回の印刷設定の件: このマクロは、その都度、列幅が紙の横に入らない時は、縮小値が変わるようになっていますが、できれば、固定値の方がよいと思います。場合により、設定時間が掛かることがあるからです。 '//'標準モジュールのみ Sub TestPrint()  Dim myRng As Range  Dim i As Long  Dim j As Long  Dim k As Long    j = 100 '印刷縮小率-初期値100%    With ActiveSheet   Set myRng = .Range("A1", .Cells(Rows.Count, "K").End(xlUp)).Resize(, 14)   For i = 1 To myRng.Columns.Count    If i <> 9 Then     .Columns(i).AutoFit    End If   Next i   With .PageSetup    .PrintArea = myRng.Address    .Orientation = xlLandscape    .PaperSize = xlPaperA4    .Zoom = j    Do     k = Application.ExecuteExcel4Macro("COLUMNS(GET.DOCUMENT(65))")     If k = 1 Then Exit Do     j = j - 1     .Zoom = j    Loop   End With   .PrintOut Preview:=True '印刷プレビューモード:ON-True, OFF-False または取る   .PageSetup.Zoom = 100  End With End Sub '// p.s.質問文を読む限りは、maron1010さんご自身でもコードを組めるレベルに来ているようです。ちょっとの勉強で、特殊なコードを使わない限り、VBAは書けるようになるはずです。

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

質問者からのお礼

すみません。 お礼ではないのですが、 印刷で 実行時エラー'1004': PageSetup クラスの Zoom プロパティを設定できません。 と出て j = j - 1 .Zoom = j ←」ここが黄色 で止まります。 ただ、何度かに1度、成功する時もありますが それが何故成功するのかは分かりません。 合わせて宜しくお願いします。

質問者からの補足

こんにちは。 いつもありがとうございます。 頂いたコードで動かしてみましたが仰る通りメッセージが幾つか出現して 私の思うものと違うので下に書きます。 ・の後がmsgboxで表示されます。()内は注釈 ←不要★ の部分を修正して頂けると助かります。 検索結果がE~I列のいずれかだった場合 C列に何も入ってなくて検索該当セル行のM列が191000####のデータを検索した時 ・(検索該当セル行のM列)191000#### ←不要★ ・指図番号191000####の部品です(上と同じ191000####) ・残りXXX品目です 検索結果がE~I列のいずれかだった場合 C列に何も入ってなくて検索該当セル行のM列が191000####以外のデータを検索した時 ・(検索該当セル行のM列を上に向かった)191000#### ←不要★ ・指図番号191000####の部品です(上と同じ191000####) ・残りXXX品目です 検索結果がE~I列のいずれかだった場合 C列に既に日付が入っていて検索該当セル行のM列が191000####のデータを検索した時 ・リストに存在しません 検索結果がE~I列のいずれかだった場合 C列に既に日付が入っていて検索該当セル行のM列が191000####以外のデータを検索した時 ・リストに存在しません 検索結果がD列だった場合 C列に何も入ってなくて検索結果行のM列が191000####のデータを検索した時 ・(M列の一番上の)191000#### (これは例外です の表示が出ない) ・(検索該当セル行のM列)指図番号191000####の部品です ←不要★ ・残りXXX品目です 検索結果がD列だった場合 C列に何も入ってなくて検索結果行のM列が191000####以外のデータを検索した時 ・(M列の一番上の)191000####これは例外です ・(検索該当セル行のM列を上に向かった)指図番号191000####の部品です ←不要★ ・残りXXX品目です 検索結果がD列だった場合 C列に既に日付が入っていて検索該当セル行のM列が191000####のデータを検索した時 ・リストに存在しません 検索結果がD列だった場合 C列に既に日付が入っていて検索該当セル行のM列が191000####以外のデータを検索した時 ・リストに存在しません '私のアレンジ 部分は興味深いのですが、データが入っている回数分msgboxが出現するのでちょっと・・・ ただ、その時、C列の既に日付が入っているセルの.End(xlToRight).Activateに出来たら助かります。 c.Offset(0, 2).Value = Date c.End(xlToRight).Activate ←ここが無い。ただ、このコードを入れても ここら↓をアクティブにしてしまう。 If c.Offset(, 2).End(xlToRight).Value <> "" Then '右に検索 Call NumberSearch(c.Offset(, 2).End(xlToRight)) '*番号探し2 D列からI列のいずれのデータをアクティブにしたい。 また、印刷についてですが少し変えさせてください。 I列(9)を J列(10)に置き換え J列以降Nまでの幅を AutoFit AからIまでの列幅を 10とさせたいのですが出来ますでしょうか? (AからIは隣合うデータが無い為10でも構わないからです) 無理難題ばかりでしょうが、宜しくお願い致します。

関連するQ&A

  • エクセルのマクロについて教えてください

    お世話になっております。 エクセルのマクロについて教えていただきたいのですが、 サンプルのファイルをこちらにアップしたのでよろしければご覧になってください。 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 でもこれを貼り付けてもうまくいきません。 正しいマクロを教えていただけないでしょうか?? 宜しくお願いいたします。 ※いつも、私の質問に対してまるで回答になってないような、ふざけた言葉を書き込んでは消してる方が一名だけいらっしゃいます。確か、鳥の写真をマイページに載せてる方です。 都度違反報告はしていますが、質問の趣旨に反する回答をされてる方一名、絶対にやめてください。

  • エクセルのマクロについて

    Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "ア") = 0 Then If InStr(.Cells(i, "D"), "ア(半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub このエクセルマクロはC列に「ア」があって、D列に「ア(半角)」の文字がない場合はメッセージというマクロなのですが、このマクロをア~ンまで同じ作業をしたいのですが、ひとまとめにマクロを組む事はできるのでしょうか?できる場合どのようにすれば良いでしょうか? 下記のようにして見たのですができませんでした。 Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "[ア-ン]") = 0 Then If InStr(.Cells(i, "D"), "[ア-ン](半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub

  • エクセル VBA の質問です。

    A2&#65374;A20までのセルに文字を入力した段階で、それぞれB2&#65374;B20に入力日時を入れるVBAを以下のように組んでいます。 しかし、同様の条件を同一シートのE2&#65374;E20・F2&#65374;F20にも入力・自動表示できるようにしなければならなくなり、困っています。 どのように記述を変えればよいのか、教えていただけたらと思います。 宜しく御願いいたします。 Sub Worksheet_change(ByVal Target As Range) Dim Rng As Range Dim c As Range Set Rng = Range("A2:A20") If Intersect(Target,Rng) Is Nothing Then Exit Sub For Each c In Intersect(Target,Rng) If Not IsEmpty(c) Then c.Offset(, 1).Value = Now Else c.Offset(, 1).ClearContents End If Next Rng.Offset(, 1).EntireColumn.AutoFit End Sub 申し訳ありませんが、何卒、宜しく御願いいたします。

その他の回答 (2)

  • 回答No.3

maron1010さんへ。 >私の思うものと違うので下に書きます。 私は、以前は、セミプロとしてVBAを書いていた関係上、これ以上は、無料掲示板上では、境界線を越えている感じがします。ある程度、ご自身の課題にしていただけないでしょうか? 体調を崩しているせいか、私は、少し、疲れてしまいました。 勝手なお願いですが、これ以上は、こちらが気が向いたらにしていただけませんか?

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

質問者からのお礼

度が過ぎました。すみません。 季節柄、ご自愛ください。

  • 回答No.1

すみません、前回の回答者です。 前回(8562170)の回答の次のリクエストでしたが、実は、言葉だけでは、何度も読み返してみても、わからなくなってしまったからです。それで、回答が付けられなくなってしまいました。 まあ、あまり期待をしないで、お待ちください。(^^; 別の方の回答が良ければ、それでも構いません。 こちらは、図をみて考えてみます。まずは、ご一報だけ。

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

質問者からのお礼

ありがとうございます。 前回、素晴らしい回答を頂いたのにも関わらず、自らの不手際で補足にて追加質問などしまして、恐縮していました。 気にかけて頂いているようで、安心しました。 大変理解し難い文章内容かと思いますが、 是非、画像を参考に(・・・なるか分かりませんが)くみ取って頂き、素晴らしい回答を待っています。 よろしくお願いします。

関連するQ&A

  • エクセルマクロで特定の範囲内の検索

    A10からA100までのセルを上から順に調べて、セルにAという文字が入力されているときに、その隣にBという文字を入力するマクロを下記のように作りました。 「セルにAという文字が入力されているとき」という条件に加え、「検索しているセルから上の9個のセル(cells(i-9,1)からcells(i-1,1)まで)にAという文字が入力されていない」という条件を加えたいのです。 Sub 検索() Dim i As Integer For i = 10 To 100 If Cells(i, 1).Value = "A" Then Cells(i, 2).value = "B" End If Next i End Sub つまり If Cells(i, 1).Value = "A" Then  の部分を If Cells(i, 1).Value = "A" かつ Range(cells(i-9,1),cells(i-1,1))にAが入力されていない Then という形にしたいのですが、表現の仕方がわかりません。 ご教示よろしくお願いします。

  • エクセル 最終行からの連続コピー

    * すぐに回答を! エクセルC20からI51までデータを1日1行ずつ入力します。 データが入力されている最終行から上に連続する10行(最終行含む)をコピーしたいのですが、最終行から10行上をどのように認識させたらいいのか、わかりません。Offsetなど試してみましたがダメでした。 よろしくお願いします。 Sub dataコピー() Dim i As Long Dim j As Integer Dim rng As Range '最後尾から10行前までを選択 With Worksheets("月").Range(Cells(20, 3), Cells(51, 10)) For i = Cells(Rows.Count, 1).End(xlUp).Row To -10? If rng Is Nothing Then Set rng = .Rows(i) End If j = j + 1 If j >= 10 Then Exit For Next i 'コピー If Not rng Is Nothing Then rng.Copy Range("M1") Beep Else MsgBox "該当行は存在しません。", 48 End If End With Set rng = Nothing End Sub コードはこちらを参考にしました &#8203;http://questionbox.jp.msn.com/qa5440189.html

  • マクロ 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

  • このマクロ、どこがおかしいですか?

    i5とj5のセルの文字が同じ場合はセル同士を結合して一つ下の行へ行き、i5とj5のセルに何も書かれていないときはそのまま一つ下の列へ行き、行った先のセルでも同じように処理(i6とj6のセルの文字が同じ場合はセル同士を結合して一つ下の行へ行き、i6とj6のセルに何も書かれていないときはそのまま一つ下の列へ行き)を繰り返し、と言うことをi33とj33のセルまで続けたいと思っています。 Sub よろしくお願いします() Dim i As Integer For i = 5 To 33 Cells(i, 9).Select If Cells(i, 9).Value = Cells(i, 10).Value Then Range(Cells(i, 9), Cells(i, 10)).Merge Selection.Offset(i + 1).Select ElseIf Cells(i, 9).Value = "" Then Selection.Offset(i + 1).Select Next i End If End Sub と書いたのですが、『Nextに対応するForがありません』と言われてしまいます。どうすれば思い通りにできるでしょうか? 極めて初心者で、伝わりにくい点があるかもしれません。よろしくお願いします。

  • Excel マクロのFor&#65374;Nextで再起動エラー

    勤務表を作っています。 下記の’OKまでは希望どうりうまく出来ていたのですが、勤務表の下セルに各列の人員(行)10名分位A,B,Cの計を表示させたい。実行するとエラー「Microsoft office Excel 再起動」を求められます。  for&#65374;が判断指令が<重い>のでしょうか。なんとか回避さする方法を教えてください。 Win XP Sp2 Office Excel 2007です。今回これを作るにあたり初VBA使用者です。 ' C入力後の翌日は休をセット。CC連続は休休セット。 Private Sub Worksheet_Change(ByVal Target As Range) Dim cnt As Variant Dim a1 As Byte Dim b1 As Byte Dim c1 As Byte Dim nin As Variant Dim retsu As Variant If Target.Count > 1 Then Exit Sub '複数セルの入力は無視 'A If Target.Value = "A" Or Target.Value = "A" Then Target.Value = "A" Range("AV16").Value = Target.Column End If 'B If Target.Value = "B" Or Target.Value = "B" Then Target.Value = "B" Range("AV16").Value = Target.Column End If 'C If Target.Value = "C" Or Target.Value = "C" Then Range("AV16").Value = Target.Column Target.Value = "C" Else End If ' If Target.Value = "C" Then If Target.Offset(0, -1).Value = "C" Then 'Cが連続したら Target.Offset(0, 1).Resize(1, 2).Value = ("休") '連休に Else End If Target.Offset(0, 1).Value = ("休")   'そうでなければ休 End If 'A,B,C の数をカウントする。 nin = Range("AV15")  '別のプログラムから入力した人員数 retsu = Range("AV16")  ' A,B,Cのいずれかを入力したセル列。Target.Column ’OK For cnt = 7 To (6 + nin) If cells(cnt, retsu) = "A" Then a1 = a1 + 1 End If If cells(cnt, retsu) = "B" Then b1 = b1 + 1 End If If cells(cnt, retsu) = "C" Then c1 = c1 + 1 End If Next cnt cells(nin + 7, retsu) = a1 'A番 cells(nin + 8, retsu) = b1 'B番 cells(nin + 9, retsu) = c1 'C番 End Sub

  • 検索マクロがおかしくなって原因がわかりません

    Sheet1のA列にはあらかじめ通し番号が1から入っていて、B列3行目からデータを入力していき、データ入力がされているまでの範囲で検索条件を満たすデータをSheet2へ表示させるマクロ実行で、いつしか、Sheet1のB列にデータが入っていないあらかじめ入力済みのA列の番号全てが検索結果として表示されるようになり、原因がわかりません。 お助けください。 Sub 未到着() Dim Rng As Range Dim i As Long Dim Deliveries As Variant Dim h As Long, j As Long Dim DataRows As Long Dim Result As String ''未到着書類(Sheet2)のフィールド行(受付番号、氏名)は、5行目に(設定して)ある With Sheet1 'Sheet1 をオープン .Activate i = 6 '6行目から該当リストを表示させる 'ユーザーフォームによるメッセージ表示 UserForm1.Show vbModeless DoEvents Set Rng = Range("B3", .Range("B65536").End(xlUp)) For Each c In Rng ' "通知書", "受領書", "預り証", "保険証書" の4項目を検索 If Application.CountA(c.Offset(, 9).Resize(, 4)) <> 4 Then 'A列から、A列を含めて14列取得し、未到着書類にコピー c.Offset(, -1).Resize(, 14).Copy Sheet2.Cells(i, 1) i = i + 1 End If Next End With 'メッセージ用のユーザーフォームを閉じる UserForm1.Hide '配列式に格納 Deliveries = Array("通知書", "受領書", "預り証", "保険証書") 'Sheet2 をオープン With Sheet2 .Activate DataRows = Range("A2", Range("A65536").End(xlUp)).Rows.Count + 1 For h = 6 To DataRows '6行目から For j = 11 To 14 '10列目~13列目 If .Cells(h, j).Value = "" Then '調べたセルの文字列0の長さだったら、 '配列より、取り出す Result = Result & ";" & Deliveries(j - 11) End If Next j If Result <> "" Then '結果が空でないなら、N列に貼り付け .Cells(h, 14).Offset(, 1).Value = Mid(Result, 2) Result = "" End If Next h End With End Sub

  • 空白セルと0値を識別させたい。(VBA)

    すみません、誰か教えていただけますか。 シートの53、54、55行目にそれぞれ値入っています。 それを3行目にビジュアル的に表現させています。 55行目はセルの色で、53行目は数値があり同じ値が 続く部分の合計を出しています。 しかし、下記の記述ですと数値が0(変数D=0)の時に うまくいきません。空白セルと認識されてしまうと思います。 何か、良い方法があれば教えて頂けませんでしょうか。 宜しくお願いします。 Sub 表示() Dim a As Long Dim c As Long Dim D As Long Dim e As String Dim f As String c = 3 For a = 3 To 64 With Worksheets("Sheet1") If .Cells(53, a) <> .Cells(53, a + 1) Then .Range(.Cells(53, c), .Cells(53, a)).Select D = WorksheetFunction.Sum(Selection) e = D f = Selection(1).Offset(1, 0).Value G = Selection(1).Offset(2, 0).Value If D <> 0 Then Selection(1).Offset(-50, 0).Value = f + "//" + e .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.Interior.ColorIndex = G End If If Selection(1).Value = "" Then .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.ClearContents Selection.Interior.ColorIndex = xlNone End If c = a + 1 End If End With Next End Sub

  • マクロが思うように動きません

    エクセル2007です。 初心者です。 マクロが思うように動きません。 指定のセルが空白の場合、msgboxを表示して、処理を抜ける 空白でない場合は、処理をつつける。 と言う事をしたいです。 with~の後が問題だと思うのですが・・ Sub 受注履歴書き込み() Dim ws01 As Worksheet, ws02 As Worksheet Dim r As Long, c As Integer, tmp As Long Set ws01 = Worksheets("受注書") Set ws02 = Worksheets("受注履歴") ws01.Activate With ws01 If .Range("C2").Value = "" _ And .Range("M2").Value = "" _ And .Range("M11").Value = "" _ And Worksheets("粗利報告書").Range("D3").Value = "" Then MsgBox "受注Noが空白です。処理を中止します。" Exit Sub ws02.Cells(r, 1).Value = .Range("C2").Value ' 受注No ws02.Cells(r, 9).Value = .Range("A40").Value ' 備考 ws02.Activate End If End With End Sub 採点願えますでしょうか? 宜しくお願い致します。

  • VBAでオートフィルを使って指定する文字列を含むものを表示させたい

    VBAを使って、セルD1に入力した文字列を検索するマクロを作りたいと思っています。 私は初心者で前に似たようなものを作ってもらって それを加工しようとしたのですが、うまくいきませんでした。 以前は完全に一致するもので表示でしたが、 今回は含むものを表示させたいです。 ワイルドカードは*をつけるのはわかるのですが、 いろいろやってみましたがダメでした。(単純なことかもしれないですけど) Private Sub Worksheet_Change(ByVal Target As Range) Dim myRng1 As Range Dim myRng2 As Range Set myRng1 = Target.Cells(1) If Application.Intersect(myRng1, Range("D1")) Is Nothing Then Exit Sub Set myRng2 = Range("D1").CurrentRegion With myRng2 If myRng1 = "" Then ActiveSheet.ShowAllData Else .AutoFilter Field:=4, Criteria1:=myRng1.Value End If End With End Sub

  • エクセル マクロ 検索

    お世話になります。 範囲がA2からK221までの表があります。 検索して検索されたセルの左のセルを表示するマクロを組みたいのですが、検索する文字(数値)はE1に、検索結果はK1に表示するようにするにはどのようにしたらいいでしょうか? Sub FIND_DATA1() ' FIND_DATA1 Macro ' マクロ記録日 : 2006/9/1 ユーザー名 : ' Cells.Find(What:=Range("E1").Value, After:=ActiveCell, lookAt:=xlWhole).Activate End Sub Sub Data_Find3() Dim 対象セル As Range Dim 最初のセル番地 As String Dim 検索件数 As Long Cells.Interior.ColorIndex = xlNone If Range("E1").Value = "" Then Exit Sub End If Set 対象セル = Cells.Find(What:=Range("E1").Value, After:=ActiveCell, lookAt:=xlWhole) 最初のセル番地 = 対象セル.Address Do 対象セル.Interior.ColorIndex = 37 検索件数 = 検索件数 + 1 Set 対象セル = Cells.FindNext(対象セル) Loop While 対象セル.Address <> 最初のセル番地 MsgBox "検索件数は" & 検索件数 - 1 & " 件です" End Sub 本を見たり調べたりでここまでできたんですがこれだと検索件数、検索結果が色付きになるだけで使い勝手がいまいちです。 よろしくお願いします。