マクロで全体から検索を行うには？ -マクロを使って特定の条件で複数のExc-

【エクセルVBA】特定のシートのみ検索したい

VBA勉強中です。フォルダにある複数のファイル（１ファイル内には複数シートあります）を順番に開けて検索をかけ、条件に合致した行をあるファイルへ転記・集約させるマクロを組みたいと思っています。（条件は1番左の列が「○」であることです。）ネットや本を参考にしながら組んでみたのですが、「○」がない（シートの）行も転記されてしまい困っています。（○があるシートは複数シートの内、１シートのみなのですが、○がないシートからも「○があるシートの○がある行」と同じ行番号の行がが転記されているようです）組んでみたマクロは以下のとおりです。 ------------------------------------------------ Sub 楕円1_Click() ActiveSheet.Range("A2:H30").ClearContents Dim ans, fn, wb, x, i, n, sh, myPath ans = "○"　'条件 myPath = ThisWorkbook.Path & "\" fn = Dir(myPath & "*.xls") '選択したフォルダ内のExcelファイル Do Until fn = "" If fn <> ThisWorkbook.Name Then 'ファイルが当ファイル以外なら Set wb = Workbooks.Open(myPath & fn) '選択したファイルを開きます For Each sh In wb.Worksheets '各シートごとに x = sh.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得 For i = 1 To x '1行目から最終行まで以下を実行します If Cells(i, 1) = ans Then '条件に合致するか検索 n = n + 1 With ThisWorkbook.Sheets("Sheet1") '転記 .Cells(n + 1, 1) = sh.Cells(i, "B") .Cells(n + 1, 2) = sh.Cells(i, "C") .Cells(n + 1, 3) = sh.Cells(i, "D") .Cells(n + 1, 4) = sh.Cells(i, "E") .Cells(n + 1, 5) = sh.Cells(i, "F") End With End If Next i Next sh wb.Close (False) '選択したファイルを閉じる End If fn = Dir() '次のファイルを検索 Set wb = Nothing Loop '繰り返し --------------------------------------------------------- このマクロでは各ファイルの全てのシートを検索していると思うのですが、全シートを検索していることが問題でしょうか？検索したいデータは特定のシートにのみ存在するので（全ファイル同じ名前のシートです）特定のシートのみ検索してくれればそれで良いのですがどう変更すればよいかわかりません。「For Each sh In wb.Worksheets '各シートごとに」　色々と調べてここを変更してみたのですが何れもエラーとなり上手くいきませんでした。どなたか上手く直す方法を教えて下さい。宜しくお願いします。

転記マクロ

売り上げ金額の合計を集計するためにマクロを作りたく過去の質問や様々なサイトを見ながらマクロを作成しています。しかし、どうしても分からない部分があるので詳しい方、お力を貸してください。 ★やりたい事同一フォルダ内に、各チームの売り上げがエクセルに入力してあります。売り上げの入力されたエクセルのテンプレートは同一で、"売上"タブに A欄：商品コード、B欄：商品名称、C欄：個数、、、、とAX欄まで続くとなっています。ただし、下へ何行に渡り入力されているかは不明です。このフォルダ内のデータを1つのエクセルファイルに集約するためのマクロを作成します。 ★教えて頂きたいこと１．以下にある私のTestマクロの"転記"の部分を、Rangeを使っての値貼り付けするための方法２．各チームが作成したエクセルファイルにある"売上"タブのみを対象とする方法(余分なタブを挿入してしまっているチームがある) ３．Rangeで貼り付けた下に改ページを挿入する方法よろしくお願い致します。 ====================================== Sub Test() Dim fn, wb, x, i, n, sh, myPath myPath = ThisWorkbook.Path & "\" fn = Dir(myPath & "*.xls") '選択したフォルダ内のExcelファイルを検索 Do Until fn = "" '全て検索し終えると、fn = Empty となるので、その間以下を実行 If fn <> ThisWorkbook.Name Then 'ファイルが自分以外なら Set wb = Workbooks.Open(myPath & fn) '選択したファイルを開く For Each sh In wb.Worksheets '各シートごとに x = sh.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得 For i = 2 To x '2行目から最終行まで以下を実行 n = n + 1 With ThisWorkbook.Sheets("Sheet1") '転記 .Cells(n, 1) = sh.Cells(i, "A") .Cells(n, 2) = sh.Cells(i, "B") .Cells(n, 3) = sh.Cells(i, "C") .......AX欄まで続く End With Next i Next sh wb.Close (False) '選択したファイルを閉じる End If fn = Dir() '次のファイルを検索 Set wb = Nothing Loop '繰り返し ThisWorkbook.Sheets("Sheet1").Copy Application.Dialogs(xlDialogSaveAs).Show Arg1:="統合.csv", Arg2:=6 End Sub

VBA　シート指定の結合

あるフォルダ配下に複数のエクセルがあります。これを以下のように１つのシートに統合したいのです。 >For Each sh In wb.Worksheets を >For Each sh In wb.Worksheets("Sheet2") としましたが，エラーで動きませんでした。いろいろやってみたり調べましたが頓挫しております。よろしくお願い致します。条件　科目名（A科目　　B科目　　C科目）のタイトル部分は不要　フォルダ配下にあるすべてのエクセルファイル内のある特定のシートの内容を統合したい。シート名は共通のものをつけています。（ファイル内の全てのシートを結合する方法は分かったのですが，ある特定のシートを指定しての統合ができません。） <１．ｘｌｓ> (sheet1) 　A科目　　B科目　　C科目 390,200 　426,200　　801,600 (sheet2) 　A科目　　B科目　　C科目 5,000 　 6,000 　7,000 <２．ｘｌｓ> (sheet1) 　A科目　　B科目　　C科目 140,500 　333,200　　 1,400 (sheet2) 　A科目　　B科目　　C科目 8,000 　 9,000　　 10,000 ↓ ＜統合.csv＞ 390,200 　426,200　　801,600 140,500 　333,200　　 1,400 ＊以下，現在までにできたVBA Sub Test() Dim fn, wb, x, i, n, sh, myPath myPath = ThisWorkbook.Path & "\" fn = Dir(myPath & "*.xls") '選択したフォルダ内のExcelファイルを検索します Do Until fn = "" '全て検索し終えると、fn = Empty となるので、その間以下を実行します If fn <> ThisWorkbook.Name Then 'ファイルが自分以外なら Set wb = Workbooks.Open(myPath & fn) '選択したファイルを開きます For Each sh In wb.Worksheets '各シートごとに x = sh.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得 For i = 2 To x '2行目から最終行まで以下を実行します n = n + 1 With ThisWorkbook.Sheets("Sheet1") '転記 .Cells(n, 1) = sh.Cells(i, "A") .Cells(n, 2) = sh.Cells(i, "B") .Cells(n, 3) = sh.Cells(i, "C") End With Next i Next sh wb.Close (False) '選択したファイルを閉じる End If fn = Dir() '次のファイルを検索 Set wb = Nothing Loop '繰り返し ThisWorkbook.Sheets("Sheet1").Copy Application.Dialogs(xlDialogSaveAs).Show Arg1:="統合.csv", Arg2:=6 End Sub

エクセルVBAで、ある条件の時

お世話になります。エクセルVBAで次のようなことをしたいのですが方法を教えてください。 formフォルダにあるすべてのファイルについて、A1セルが「0」でないとき、 A4:B7及びA9:B12の中で日付が入っている行の日付と内容を、ActiveWorksheetのB列、C列にレコードとして取り出したいのです。（A列はナンバリングになります） --------formフォルダの中にあるブック--------- 　　A　　B 1　23 2 3　日付　内容　　　'この行は固定です 4　5/13　あああ 5　5/17　いいい 6 7 8　日付　内容　　　'この行は固定です 9　5/16　ううう 10　5/12　えええ 11 12　5/10　おおお ---ThisWorkbook（前に助けていただいたコードです）--- Sub data_torikomi2() 　　Dim wb As Workbook 　　Dim Fn As String 　　Dim myPath As String 　　Dim dbBkSh As Worksheet 　　Dim i As Long 　　For Each wb In Workbooks 　　　　If wb.Name <> ThisWorkbook.Name And _ 　　　　InStr(1, wb.FullName, "form\", 1) > 0 Then 'formを検索　　　　　　wb.Close '閉じる　　　　End If 　　Next wb 　　myPath = ThisWorkbook.Path & "\" 　　Set dbBkSh = ThisWorkbook.Worksheets("一覧表") 　　　　　　　　　Range("4:1000").Clear '全データ削除　　Fn = Dir(myPath & "form\*.xls") 　　i = 1 　　'画面のちらつきを抑える　　Application.ScreenUpdating = False 　　Do Until Fn = "" 　　　　If Fn <> ThisWorkbook.Name Then 　　　　　　With Workbooks.Open(myPath & "form\" & Fn, , True) 　　　　　　　　dbBkSh.Range("A3").Offset(i, 0).Value = i 　　　　【★たぶんこの部分に入るものです★】　　　　　　　　.Close False 　　　　　　　　i = i + 1 　　　　　End With 　　　　End If 　　　　Fn = Dir() 　　Loop 　　Application.ScreenUpdating = True 　　Set dbBkSh = Nothing End Sub ご教示よろしくお願いします。

全部の列でSelection.NumberFormatLocal = "0.00"になってしまう

以前こちらでお世話になった者です。教えていただいたコードを応用したのですが、うまくいきません。以下のようにすると、最後にすべての列の数値が0.00の形になってしまいます。どこが悪いのか教えてください。よろしくお願いします。 Sub data_torikomi9_1() Dim wb As Workbook Dim Fn As String Dim myPath As String Dim dbBkSh As Worksheet Dim i As Long For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name And _ InStr(1, wb.FullName, "form\", 1) > 0 Then 'formを検索 wb.Close '閉じる End If Next wb myPath = ThisWorkbook.Path & "\" Set dbBkSh = ThisWorkbook.Worksheets("様式9-1") With dbBkSh.UsedRange If .Cells(.Cells.Count).Row > 10 Then .Range("A11", .Cells(.Cells.Count)).Clear End If End With Fn = Dir(myPath & "form\*.xls") i = 1 '画面のちらつきを抑える Application.ScreenUpdating = False Do Until Fn = "" If Fn <> ThisWorkbook.Name Then With Workbooks.Open(myPath & "form\" & Fn, , True) '会社名と企業コード dbBkSh.Range("E2").Value = .Worksheets("inputform").Range("C2").Value dbBkSh.Range("B2").Value = .Worksheets("inputform").Range("M2").Value 'A11 - 1 dbBkSh.Range("A10").Offset(i, 0).Value = i 'B11 - 氏名 dbBkSh.Range("A10").Offset(i, 1).Value = .Worksheets("inputform").Range("C7").Value 'C11 - 番号 dbBkSh.Range("A10").Offset(i, 2).Value = .Worksheets("inputform").Range("H29").Value 'D11 - ポイント dbBkSh.Range("A10").Offset(i, 3).Value = .Worksheets("inputform").Range("H32").Value .Close False i = i + 1 End With End If Fn = Dir() Loop Columns("B:C").Select Selection.HorizontalAlignment = xlLeft Columns("C:C").Select Selection.NumberFormatLocal = "00000" Columns("A:A").Select Selection.HorizontalAlignment = xlCenter Columns("D:D").Select Selection.NumberFormatLocal = "0.00" Range("A6").Select Application.ScreenUpdating = True Set dbBkSh = Nothing End Sub

エクセルVBAで別BOOKに「名前の定義」のCopy

前からあったエクセルのファイルのどこかが壊れたらしく、ときどき作業中に突然エラーとなってエクセル自体が落ちてしまうので、BOOKの複製では意味がないと考え、同じ内容のものを別BOOKに再作成するマクロを以下のとおり作ってみました。（新規作成のBOOKにこのマクロを貼ります）これで、VBAのモジュールを除き、再作成できたのですが、どういうわけか「名前の定義」を行なったセル範囲の一部が反映されません。調べてみると、他のセルから参照されていない「名前の定義」がすっぽり抜け落ちるようにも思えるのですが、この理解であっているでしょうか？他のセルから参照していなくとも、マクロで参照しているので抜け落ちるのは困ります。どうすれば、すべての「名前の定義」が再作成されるでしょうか？ Sub Book_Copy() Dim fn As String Dim wb1 As Workbook, wb2 As Workbook Dim ans As Integer, i As Integer Dim nm As Name Dim sh As Worksheet fn = Application.GetOpenFilename("エクセルファイル (*.xls), *.xls") If fn = "False" Then Exit Sub Application.EnableEvents = False Set wb1 = Workbooks.Open(Filename:=fn, UpdateLinks:=1) Set wb2 = ThisWorkbook ans = MsgBox(wb1.Name & "を " & wb2.Name & " へCopyしますか？", vbYesNo + vbQuestion) If ans = vbNo Then Exit Sub For Each nm In wb2.Names nm.Delete Next nm For Each sh In wb1.Worksheets sh.Cells.Copy i = i + 1 If wb2.Worksheets.Count = i Then wb2.Worksheets.Add After:=Worksheets(i) Application.DisplayAlerts = False wb2.Activate wb2.Worksheets(i).Activate wb2.Worksheets(i).Cells.Select ActiveSheet.Paste wb2.Worksheets(i).Name = sh.Name Application.DisplayAlerts = True Application.CutCopyMode = False End If Next sh wb1.Close (False) Application.EnableEvents = True ActiveWorkbook.ChangeLink Name:=fn, NewName:=wb2.Name, Type:=xlExcelLinks Set wb1 = Nothing Set wb2 = Nothing End Sub

行ごとに判定するマクロについて教えて下さい

行ごとに判定するマクロについて教えて下さい。下記のようなマクロで、添付ファイルのように、行ごとで E列からN列で違った数値がないか、入力されていないセルがないかを調べ４つすべてのセルが同じ数値でない場合は塗りつぶしはされず O列にOKを表示しないようなマクロを組みたいのですが現在のマクロだと、行ごとではなく、E3～N102セルまでの中で同じ数値がないかを判断してしまっているため K11セルやK15セルのように数値が入力されていないにも関わらずO列の部分にOKが出てしまいます。他の行に同じ数値が入っているのは関係なしにして 11行目なら11行目だけで 15行目なら15行目だけで、というように行ごに判定していくにはどのようにすればいいでしょうか？ Sub 判定マクロ回転() Dim i As Integer, j As Integer Range(Cells(3, 15), Cells(102, 15)).ClearContents For i = 3 To 102 For j = 5 To 14 Cells(i, j).Interior.ColorIndex = 0 If WorksheetFunction.CountIf(Range("E3:N102"), Cells(i, j)) > 3 Then If Cells(i, j).Row Mod 2 = 1 Then Cells(i, j).Interior.ColorIndex = 6 Cells(i, 15) = "OK" Else If Cells(i, j).Row Mod 2 = 0 Then Cells(i, j).Interior.ColorIndex = 40 Cells(i, 15) = "OK" End If End If End If Next j Next i If WorksheetFunction.CountIf(Range("O3:O102"), "OK") > 99 Then MsgBox "データチェックOK(^O^)b" End If End Sub

マクロでファイル名(を含む)を検索しPDFを開く

マクロでファイル名（セルの値）を含むPDFファイルを検索し、ファイルが存在していればそのファイルを開きたいのですがうまく行きません。 Sub を含むPDFファイルを開く() Dim keyword As Variant Dim myPath As Variant Dim fName Dim pname Set my = ActiveSheet keyword = my.Range("D2").Value '検索する値 myPath = my.Range("F1").Value　　'フォルダパス fName = Dir(myPath & "*" & keyword & "*" & ".pdf") pName = (myPath & "*" & keyword & "*" & ".pdf") 　'"*" & keyword & "*"が良くないのだと思います。 If fName = "" Then MsgBox ("該当するファイルが存在しません。") Exit Sub End If With CreateObject("Wscript.Shell")　 .Run pname, 5　　'ここでエラーが出ます。 End With End SUB 'pname内の"*" & keyword & "*"をkeywordのみにすると完全一致のファイルは開けるのですが部分一致で開きたいため”*”を使用したところエラーが出てしまいます。また、検索するPDFファイルにスペースが含まれていても開けるようにしたいのです。どうかご指導のほうをよろしくお願いします。

エクセルでフォルダまたはファイルを開くマクロですが、どのように改良すれ

エクセルでフォルダまたはファイルを開くマクロですが、どのように改良すればよろしいでしょうか？下記マクロは、エクセルシートのJ列のあるセルをダブルクリックすると、そのセルに記入された文字列を検索して、該当のフォルダまたは、写真が開きます。（エクセルファイルと写真は同フォルダに保存している場合のみ有効）困っていることは、J列のセルと該当フォルダまたは、写真ファイルをリンクさせたいのですが、文字列が全て一致している時のみしか開かないことです。 D<デジカメ<商品名フォルダ＜写真ファイル例えば　セルＪ3の文字列がABCEで、フォルダ名またはファイル名がABCDEFであった場合、文字列ABCEを含む条件で、フォルダ名またはファイル名ABCDEFを開くように改良したいのですが、また、エクセルファイルと写真ファイルの保存場所は、全く違うフォルダにしたいのですが、エクセルファイルと写真ファイルは、別フォルダの場合、どのように検索先フォルダのパスを入れたら良いのでしょうか？マクロに詳しい方ご教授下さい。よろしくお願い致します。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim myPath As String If Target.Cells(1, 1).Column <> 10 Then Exit Sub Cancel = True myPath = ThisWorkbook.Path & "\" & Target.Cells(1, 1).Text If Dir(myPath, vbDirectory) <> "" Then Shell "explorer.exe /e,/root," & myPath, vbNormalFocus Exit Sub End If myPath = Replace(LCase(myPath), ".jpg", "\" & Target.Cells(1, 1).Text) If Dir(myPath, vbNormal) <> "" Then Shell "rundll32.exe shimgvw.dll,ImageView_Fullscreen " & myPath, vbNormalFocus End If 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

マクロ　検索できなかった検索値を表示したい

C列を複数の検索値で検索して見つからなかった検索値が一つでもあればその検索値をメッセージBOXに表示した上でどの検索値であっても同じ処理をしたいです。全て検索できた場合は別の処理をしたいです。今自力で出来るのは以下の記述ですが同じ処理を6回も記述しておりメンテしにくいです。また、記述順で最初に見つからなかった検索値だけしか表示できない（それでも問題は無いです）という弱点もあります。他に方法はありますでしょうか？配列関連は自力で作成出来ませんので他の方法にてアドバイスをいただけたらと思います。 C列には果物名がランダムに10,000行入力されています。検索値を・みかん・りんご・バナナ・いちご・すいか・メロンとしてそれらが全て存在するか検索し一つでも存在しない場合はその検索値をメッセージBOXに表示した上でどの検索値であっても同じ処理を行う。全て検索できた場合は次の処理を行う。 Sub 実験2() Dim 範囲 Set 範囲 = ThisWorkbook.Worksheets("マスタ").Columns("C:C") Set rngFind = 範囲.Find("みかん") If rngFind Is Nothing Then MsgBox "ファイル【みかん】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("りんご") If rngFind Is Nothing Then MsgBox "ファイル【りんご】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("バナナ") If rngFind Is Nothing Then MsgBox "ファイル【バナナ】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("いちご") If rngFind Is Nothing Then MsgBox "ファイル【いちご】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("すいか") If rngFind Is Nothing Then MsgBox "ファイル【すいか】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If Set rngFind = 範囲.Find("メロン") If rngFind Is Nothing Then MsgBox "ファイル【メロン】が取込まれていません。", vbExclamation, "【警告】" MsgBox "今までの作業を保存しないで" & vbCrLf & _ "プログラムを終了します", vbExclamation, "終了" MsgBox "ただし【マスタ】はすでに削除されています。 " & vbCrLf & _ "必ず【マスタ更新】をやり直してください。", _ vbExclamation, "注意してください" ThisWorkbook.Sheets("マスタ").Select Cells.Select 'Sheets Selection.Delete Shift:=xlUp Range("A1").Select ThisWorkbook.Sheets("メニュー").Select Range("A2").Select End '終了 End If 次の処理 End Sub

エクセルのマクロで教えてください

いつもお世話になっています。先日、こちらのサイトでマクロをコピーさせて頂いて使っていました。以下のようなマクロです ub test01() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Worksheets("統合表") j = 2 '統合表のデータ書きこみ開始行 For Each sh2 In ActiveWorkbook.Worksheets If sh2.Name = "統合表" Then Exit For '統合表は統合対象外 d = sh2.Range("A65536").End(xlUp).Row '各シートの最終行を知る ' MsgBox d For i = 63 To d '各シートの開始行２から最終行まで統合表に移す sh1.Cells(j, "C") = sh2.Cells(i, "C") sh1.Cells(j, "Q") = sh2.Cells(i, "Q") sh1.Cells(j, "T") = sh2.Cells(i, "T") sh1.Cells(j, "AM") = sh2.Cells(i, "AM") sh1.Cells(j, "AR") = sh2.Cells(i, "AR") sh1.Cells(j, "AU") = sh2.Cells(i, "AU") sh1.Cells(j, "BB") = sh2.Cells(i, "BB") sh1.Cells(j, "BI") = sh2.Cells(i, "BI") '列数だけこの後にコードを増やすこと j = j + 1 '統合表の直下行をポイント Next i Next End Sub このマクロでは２行目から以降を呼んでくることになっていますが、これを２行目から６０行目までだけ呼んでくるようにしたいのです。どうしたら良いか教えていただけないでしょうか？つたない文章ですみません。よろしくお願いします。

【Excelマクロ】もっと頭の良い書き方って無いかな？

5行空白列があったらそこで処理を終わりたいんですが、もっといい書き方はないでしょうか？下記が私の考えた頭の悪いやり方です。 Sub macro() Dim i As Integer For i = 1 To 1000 If Cells(i, 1) = "" Then 　If Cells(i + 1, 1) = "" Then 　　If Cells(i + 2, 1) = "" Then 　　　If Cells(i + 3, 1) = "" Then 　　　　If Cells(i + 4, 1) = "" Then 　　　　　If Cells(i + 5, 1) = "" Then 　　　　　　MsgBox (i - 1 & "行目で終わりです") 　　　　　　Exit For 　　　　　End If 　　　　End If 　　　End If 　　End If 　End If End If Next End Sub

エクセル　検索コピーマクロ

マクロで検索、抽出して別ファイルに保存したいのですが、以下のようなマクロを教えてもらったのですがコピー先のセル位置を任意の位置に直したいのですが、どうしてもわかりませんどの部分をどう直せばよいのでしょうか？ Option Explicit Sub copyTodayData() Dim dateToday As String Dim tempDate As String Dim lastrow1 As Long Dim lastrow2 As Long Dim i As Long Dim fileA As String Dim anotherBook As String Dim anotherFilePath As String fileA = ThisWorkbook.Name anotherBook = "別のファイル.xls" anotherFilePath = "C:\Documents and Settings\日本太郎\デスクトップ\どこかのフォルダ" '問い合せダイアログの表示をOFFにします Application.DisplayAlerts = False 'ファイルを開く ChDir anotherFilePath Workbooks.Open Filename:=anotherFilePath & "\" & anotherBook '問い合せダイアログの表示をONに戻します Application.DisplayAlerts = True 'ウインドウの切替 Windows(fileA).Activate '今日の日付を取得 dateToday = Date 'データ最終行を取得 lastrow1 = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow1 If Cells(i, 1) = dateToday Then 'Range(Cells(i, 1), Cells(i, 4)).Copy 'コピー Windows(anotherBook).Activate 'ウインドウの切替 lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ActiveSheet.Paste Windows(fileA).Activate 'ウインドウの切替 End If Next i MsgBox "実行しました" End Sub たぶん、lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ここらへんというのは、わかりますが、どこをどう変えたらいいかわかりません

エクセル、比較、コピー、貼り付けのマクロ

エクセルについて同じシート内にあるＢ列２行目から６６行目までとＩ列２行目から３３３行目までのセルを比較し、Ｂ列２行目とＩ列２行目がおわったらＢ列２行目とＩ列３行目を比較という流れになる。Ｉ列の比較が３３３行目まで終わったら、Ｂ列３行目とＩ列２行目を比較し、終わったらＢ列３行目とＩ列３行目を比較していきます。同じ数値のセルがあったら (1)Ａ列～Ｅ列（行は値が一致した行）をコピー (2)Ｈ列～Ｌ列（行は値が一致した行）をコピーし、 (1)はＭ列に貼り付け (2)はＲ列に貼り付けＶＢＡのコードは以下の様になります Sub t() x = 2 y = 2 g = 1 n = 1 Do Do If Cells(x, 2) = Cells(y, 9) Then Range(Cells(x, 1), Cells(x, 5)).Copy Destination:=Cells(g, 13) Range(Cells(y, 8), Cells(y, 12)).Copy Destination:=Cells(n, 18) y = y + 1 g = g + 1 n = n + 1 Else y = y + 1 End If Loop While y < 334 Loop While x < 67 End Sub これを実行すると実行エラー１００４　アプリケーション定義又はオブジェクト定義のエラーになります。誰か回答をお願いします。

エクセルこのマクロはどこが間違っているのでしょうか。

いつもお世話になります。エクセルで、別ファイルにある表の、同じ商品コードのデータをつなげようしています。 <開いている表；タイトルを除くと12行目から開始> 列V　　～　　列AC 商品コード　テキストデータ <別ファイルの表；タイトルを除くと20行目から開始> 列B　　～　　列T 商品コード　（空白）←このセルに、列ACのデータを入れたい下記のマクロを作成し、実行してみたのですが、結果は、sh1のセル"T20"（＝最初の行）にのみ値が入り、後は空白のままでした。お手数をおかけしますが、修正箇所と、何が原因で、2行目以降に働かないのかを教えていただけますでしょうか。 Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Workbooks("Book1.xls").Worksheets("sheet1") Set sh2 = Workbooks(ThisWorkbook.Name).Worksheets("sheet2") l = 20 For m = 12 To 2012 Step 1 If sh2.Cells(m, "V") = sh1.Cells(l, "B") Then sh1.Cells(l, "T") = sh2.Cells(m, "AC") l = l + 1 End If Next m

他ブックからのシートコピーのマクロ

マクロ初心者です。下記マクロを完成する事が出来たのですが、一部修正がうまくいかない為投稿させていただきました。マクロ内容：エクセルファイルを指定し、選択したシートを現在のブックにコピーするその際、不要な名前管理を削除してからコピー修正したい箇所：指定したブックからコピーした際、シート参照の数式が入っていると外部参照になってしまう。やってみた事：(1)(i)の前にarrayを入れる→外部参照のまま (2)(i)を削除してみた→外部参照にならなくたったが際限なくシートをコピーし続けた Sub 名前管理削除() Dim myPath As String Dim wb_A As Workbook Dim i As Integer ' myPath = Application.GetOpenFilename(("Excelファイル,*.xls*,CSVファイル,*.csv"), , "ブックを選択して下さい。") If myPath = "False" Then Exit Sub Set wb_A = Workbooks.Open(myPath) Dim name As Object For Each name In Names If name.Visible = False Then name.Visible = True End If Next On Error Resume Next ' エラーを無視。(削除件数にカウントしてしまいます) For Each nm In ActiveWorkbook.Names If InStr(nm.Value, "#REF") > 0 Or _ InStr(nm.Value, "\") > 0 Then nm.Delete i = i + 1 Else End If Next nm ' 終了の表示 MsgBox "不要な名前定義を削除しました。" & vbCr & _ "削除定義件数=" & i & "件", vbInformation, cnsTitle For i = 1 To wb_A.Sheets.Count wb_A.Sheets(i).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Next wb_A.Close False End Sub 不勉強で申し訳ございませんが、何卒よろしくお願いいたします。

マクロで全てのシートで条件を満たすシートに行を挿入するにはどうしたらいいですか

マクロ初心者です。自分でも作ってみたのですが、なかなか思うようにいかず困っています。 book内のシート3つ目から最後のシートで、条件に一致するシートの特定位置に行を挿入するということがしたいのですが。条件とは、1列目の最後の行に「合計」と記入されていれば、行を4行挿入し、上の書式をコピーするというものです。下記に記しているマクロは、シートを指定した場合には動くのですが、これにシートをnとして、FOR...Nextを付け加えてシートを順番に参照させようとしても、うまくいきません。 Sub 行挿入sample3() With Sheets("10007") For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row If .Cells(i + 1, 1) = "" Then Exit For ElseIf .Cells(i + 1, 1) = "合計" Then Range(Cells(i + 1, 1), Cells(i + 4, 1)).Select Selection.EntireRow.Insert Range(Cells(i, 1), Cells(i, 3)).Select Selection.Copy Range(Cells(i + 1, 1), Cells(i + 4, 3)).PasteSpecial xlPasteFormats End If Next i End With End Sub 知識をお持ちの方、教えていただけるととても助かります。よろしくお願いします。

Excelで条件にあったセルを検索して、行全体に色をつける方法

こんにちは初歩的な質問で大変恐縮なのですが、助けていただけませんでしょうか。エクセルのシート上のG列4～120行に入っている数値を検索して、その値が条件を満たす場合にその行全体に色をつけたいと思い、以下のようなコードを書いてみたのですが、「型が一致しません」というエラーがでてしまいます。(色は一応つくのですが・・・) Sub TestMacro() 　Dim i As Integer 　　For i = 4 To 120 　　If Sheets("aaa").Cells(i, "G").Value < 365 Then 　　　Sheets("aaa").Rows(i).Select 　　Selection.Interior.ColorIndex = 7 　End If Next i End Sub この原因は何なのでしょうか？教えてください。宜しくお願いします。

VBA　探しているFileがないときの処理方法

現在、下記のようにしてマクロ実行ブックと同じ階層のフォルダ名を取得してAに、フォルダ内のabc.XLSのC9の値をBに、abc.XLSの更新日時をCに表示させています。このとき、フォルダ内にabc.XLSが無い場合にファイル名をAに書き出してB及びCは空白というように表示したいのですが、どのようにすればよろしいでしょうか。 macro1は以前質問させて頂いたものがベースになっています。ExecuteExcel4Macroを使っている関係でファイル名が無いときの処理はDirを使ってできるとmougで調べてわかりましたが、自分の知識ではできず、macro2を作成したのですが、指定ファイルがない場合の処理がうまくできずにいます。 macro1はファイルオープンの窓が開きます。macro2はファイルが存在しないという窓が開きます。どちらの場合でもかまいませんのでお力をお貸し頂けませんでしょうか。 Sub macro1() Dim myPath As String Dim myFolder As String Dim r As Long r = 3 myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" Application.ScreenUpdating = False Range("A3:C60").Clear Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Cells(r, 1) = myFolder Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3") On Error Resume Next Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook) On Error GoTo 0 If Cells(r, 3) = "" Then Cells(r, 2) = "myBook" End If Cells(r, 2).NumberFormatLocal = "#,##0_ " Cells(r, 3).NumberFormatLocal = "y""年""m""月""" With Range("A3:C60") .Sort Key1:=Range("C3"), Order1:=xlAscending .Borders.LineStyle = True End With r = r + 1 End If End If myFolder = Dir() Loop Application.ScreenUpdating = True End Sub Sub Macro2() Dim myPath As String Dim myFolder As String Dim myBook As String myPath = ThisWorkbook.Path & "\" myFolder = Dir(myPath, vbDirectory) myBook = "abc.XLS" i = 2 Do Until myFolder = "" If myFolder <> "." And myFolder <> ".." Then If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then Workbooks.Open (myPath & myFolder & "\" & myBook) Range("C9").Activate Selection.Copy ThisWorkbook.Activate Cells(i, 1) = myFolder Cells(i, 2).PasteSpecial xlValues Cells(i, 3) = FileDateTime(myPath & myFolder & "\" & myBook) Workbooks(myBook).Close SaveChanges:=False i = i + 1 End If End If myFolder = Dir() Loop End Sub

マクロで全体から検索を行うには？

マクロで全体から検索を行うには？

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

お礼 2009/04/08 14:10

関連するQ&A

【エクセルVBA】特定のシートのみ検索したい

転記マクロ

VBA　シート指定の結合

エクセルVBAで、ある条件の時

全部の列でSelection.NumberFormatLocal = "0.00"になってしまう

エクセルVBAで別BOOKに「名前の定義」のCopy

行ごとに判定するマクロについて教えて下さい

マクロでファイル名(を含む)を検索しPDFを開く

エクセルでフォルダまたはファイルを開くマクロですが、どのように改良すれ

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

マクロ　検索できなかった検索値を表示したい

エクセルのマクロで教えてください

【Excelマクロ】もっと頭の良い書き方って無いかな？

エクセル　検索コピーマクロ

エクセル、比較、コピー、貼り付けのマクロ

エクセルこのマクロはどこが間違っているのでしょうか。

他ブックからのシートコピーのマクロ

マクロで全てのシートで条件を満たすシートに行を挿入するにはどうしたらいいですか

Excelで条件にあったセルを検索して、行全体に色をつける方法

VBA　探しているFileがないときの処理方法

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

マクロで全体から検索を行うには？

マクロで全体から検索を行うには？

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

お礼 2009/04/08 14:10

関連するQ&A

【エクセルVBA】特定のシートのみ検索したい

転記マクロ

VBA シート指定の結合

エクセルVBAで、ある条件の時

全部の列でSelection.NumberFormatLocal = "0.00"になってしまう

エクセルVBAで別BOOKに「名前の定義」のCopy

行ごとに判定するマクロについて教えて下さい

マクロでファイル名(を含む)を検索しPDFを開く

エクセルでフォルダまたはファイルを開くマクロですが、どのように改良すれ

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

マクロ 検索できなかった検索値を表示したい

エクセルのマクロで教えてください

【Excelマクロ】もっと頭の良い書き方って無いかな？

エクセル 検索コピーマクロ

エクセル、比較、コピー、貼り付けのマクロ

エクセル このマクロはどこが間違っているのでしょうか。

他ブックからのシートコピーのマクロ

マクロで全てのシートで条件を満たすシートに行を挿入するにはどうしたらいいですか

Excelで条件にあったセルを検索して、行全体に色をつける方法

VBA 探しているFileがないときの処理方法

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

VBA　シート指定の結合

マクロ　検索できなかった検索値を表示したい

エクセル　検索コピーマクロ

エクセルこのマクロはどこが間違っているのでしょうか。

VBA　探しているFileがないときの処理方法