VBAの.WorksheetFunctionについて

このQ&Aのポイント
  • VBAの.WorksheetFunctionについてエラーが発生しています
  • 質問文章のコードには修飾子の不正やLoopとDoの対応がないエラーがあります
  • 解決方法は、namebookを開いた後にThisWorkbookのsheet3のC列にnamebookのsheet1のC列が存在するかチェックし、存在すればnamebookを閉じ、存在しなければコピーすることです
回答を見る
  • ベストアンサー

VBA .WorksheetFunctionについて

Dim DestBook As Workbook Dim pathmacrobook As String Dim namebook As String Dim myb As Range Dim r As Long Application.ScreenUpdating = False ThisWorkbook.Activate pathmacrobook = ThisWorkbook.Path & "\" & Worksheets("sheet1").Cells(1, 3).Value & "\" Set DestBook = Workbooks("残高集計用.xls") namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set myb = DestBook.Worksheets("sheet3").Range("A65536").End(xlUp) With Workbooks.Open(pathmacrobook & namebook) r = aplication.WorksheetFunction.MatchThisWorkbook.Worksheets("sheet1") .Range("C3:AH3"), namebook.Worksheets("sheet1").Range("C"), 0) If r > 0 Then .Close False Else With Workbooks.Open(pathmacrobook & namebook) .Worksheets("Sheet1").UsedRange.Offset(1).Copy myb.Offset(1)      lngREC = lngREC + 1 .Close False End With End If namebook = Dir() Loop Set DestBook = Nothing MsgBox lngREC & "日分" & "読込完了しました" 上記のコードについてですが、修飾子が不正です。や、 Loopに対するDoがありません等エラーが出てしまいます。 やりたい事は、"namebook"を開いた時、"Thisworkbook"のsheet3のC列に"namebook"のsheet1のC列があれば、 "namebook"閉じ、そうでなければコピーするというようにしたいです。 どなたかご教授お願いします。

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

  • ベストアンサー
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.4

こんにちは。 * >・MATCH関数を使うのがナンセンスという事でしょうか? ナンセンス(無意味)ということではありません。きちんとした使い方があります。 まず、以下ですが、 自ブックを動かさないなら、 Dim mySheet As Worksheet Set mySheet = ThisWorkbook.Worksheets("Sheet1") 'このように、親オブジェクトからまとめると、ひとつになります。 ---------------------------------------------- ---------------------------------------------- With Workbooks.Open(pathmacrobook & namebook) > r = WorksheetFunction.Match(ThisWorkbook.Worksheets("sheet1").Range("C3:AH3"), namebook.Worksheets("sheet1").Range("C"), 0)   ↓ r =WorksheetFunction.Match(MySheet.Range("C3:AH3"), .Worksheets("sheet1").Range("C:C"), 0) となりますね。しかし、本来、これでは、 Match(検査値,検査範囲,照合の型) というワークシート関数の形がありますから、その検索値に範囲 "C3:AH3" を入れたら、そのままでは、VBEditor 側では働きません。それは、ワークシートで、数式を見ても、どのように検索しているか分からないのです。ワークシートで正しく検索できていることが、条件ですから。最後に、もう一度書きます。 >・Set = Workbook(namebook).Worksheets("sheet1").Range("C") >とすると、ローカルウィンドウでは”Nothing”となっていました。 >・Dim ○ As ○としたときに、オブジェクトがありません。とういう >時は、Workbook()が足りないという事でよろしいでしょうか? 「 .Worksheets("sheet1").Range("C:C"), 0)」 これは、上の部分をみてください。ワークブックのオブジェクトを確保したら、そのオブジェクトを利用する場合、With ステートメントが書かれているのですから、それを利用します。 ** また、こういう部分は、 Dim myDestSheet As Worksheet Set myDestSheet = DestBook.Worksheets("sheet3") ---------------------------------------------- ---------------------------------------------- > Set myb = DestBook.Worksheets("sheet3").Range("A65536").End(xlUp)   Set myb = myDestSheet.Range("A65536").End(xlUp) とすれば短くなります。 ところで、VBAのコードでは、どうもちぐはぐな感じがしてくるのです。With ステートメントを使っているわりには、ご質問の内容では、なぜか、そのWithステートメントの意味が分かっていらっしゃらなかったりするようです。ここらは、基礎的なもので、VBAの教本の最初の方に、「基本文法」という部分にあります。 また、ワークシート関数の部分は、Excel自体を使う意味では、「致命的」です。他は大した問題とは思いません。そこがクリアしないと、絶対にコードが通らないのです。仮に、私が、お手本を示しましょうと思っても、どうしても、その部分は、意味が分からないので、全体としては、書けないのです。 *** 基本的な、サンプルを示します。 一度、研究してみてください。 A列に a b c ・ ・ z と入れて、B1 に検索値を入れます。 Sub TestSample1() Dim r As Long r = WorksheetFunction.Match(Range("B1"), Range("A:A"), 0) If r > 0 Then   MsgBox r,vbInformation End If End Sub 値が見つかれば、数字が出ますが、値が見つからないと、 ----------------------------------------- 実行時エラー '1004':  WorksheetFunction クラスのMatch プロパティを取得できません。 ----------------------------------------- と出ます。 Sub TestSample2() Dim r As Long On Error Resume Next r = WorksheetFunction.Match(Range("B1"), Range("A:A"), 0) If r > 0 Then  MsgBox r,vbInformation End If On Error GoTo 0 End Sub では、こうしたらどうでしょうか? 確かに、エラーは出なくなりました。ところが、これをループしてみるとおかしな現象が出てきます。 今、B1~B3 に、c, a, 3 と入れました。 Sub TestSample3()   Dim r As Long   Dim i As Long   On Error Resume Next   For i = 1 To Range("B65536").End(xlUp).Row     r = WorksheetFunction.Match(Cells(i, 2), Range("A:A"), 0)     If r > 0 Then       MsgBox r,vbInformation     End If   Next i   On Error GoTo 0 End Sub なぜか、3番目は、2回目と同じ答えが出てきます。 つまり、これでも、うまくないわけです。 そこで、 r = 0 をr = WorksheetFunction.Match の前に入れてみると、 初めて、正しい検索がなされます。 ただ、こういう書き方は、正規の書き方で、 掲示板では、Application.Match という書き方が流通しています。 Sub TestSample4()   Dim r As Variant 'Long型は不可   Dim i As Long   On Error Resume Next   For i = 1 To Range("B65536").End(xlUp).Row     r = 0     r = Application.Match(Cells(i, 2), Range("A:A"), 0)     If IsError(r) = False Then       MsgBox r, vbInformation     End If   Next i   On Error GoTo 0 End Sub **** >何とか自分の手で完成させたいので、 それは分かるのですが、通らないコードでも、ここを直せばよいというものと、そうでないものがあります。成り立たない数式では、他人には意味が分からないのです。 ThisWorkbook.Worksheets("sheet1").Range("C3:AH3") namebook.Worksheets("sheet1").Range("C") ワークシートでも、 =MATCH(C3:AH3,C,0) 入力した式は正しくありません、と出るのではありませんか? =MATCH(C3:AH3,C:C,0) としたら、今度は、#N/A と出ませんか? これでは、無理なのですね。そこは、VBAではありませんから、回答者側からは、修正できないのです。

mimoule1998
質問者

補足

Wendy02様 非常に長くにわたり、ご解説いただきありがとうございます。本当に感謝しています。 まず、MATCH関数の使い方が間違っていました。 いろいろ研究した結果、下記のようにコードを書きました。 IFの部分で、r = 1 になった場合の動作は問題ありませんでした。 Dim DestBook As Workbook Dim pathmacrobook As String Dim namebook As String Dim myb As Range Dim myasheet As Worksheet Dim mybsheet As Worksheet Dim r As Variant Dim mypath As Workbooks Application.ScreenUpdating = False '画面の更新をさせない pathmacrobook = ThisWorkbook.Path & "\" & Worksheets("sheet1").Cells(1, 3).Value & "\" '変数の設定 Set DestBook = Workbooks("残高集計用.xls") '変数の設定 namebook = Dir(pathmacrobook & "*.xls") '変数の設定 Do While Not namebook = "" 'namebookのファイルを全部開くまで続ける Workbooks.Open (pathmacrobook & namebook) Set myb = DestBook.Worksheets("sheet3").Range("A65536").End(xlUp) 'sheet3の一番下のセルを選択する Set myasheet = DestBook.Worksheets("sheet3") Set mybsheet = Workbooks(namebook).Worksheets("sheet1") r = 0 r = Application.WorksheetFunction.Match(mybsheet.Range("C2"), myasheet.Range("C2:C65536"), 0) If r > 0 Then lngREC2 = lngREC2 + 1 Workbooks(namebook).Close False Else mybsheet.UsedRange.Offset(1).Copy myb.Offset(1) 'sheet1の使っている範囲を一段下げて、mybにコピーする lngREC = lngREC + 1 '回数をカウントする Workbooks(namebook).Close False 'ファイルを閉じる End If namebook = Dir() Loop Set DestBook = Nothing MsgBox lngREC2 & "日分は読込されていました" & vbCr & lngREC & "日分" & "読込完了しました" ※r = Application.WorksheetFunction.Match(mybsheet.Range("C2"), myasheet.Range("C2:C65536"), 0) ご指摘いただいた通り、上記の部分で ----------------------------------------- 実行時エラー '1004':  WorksheetFunction クラスのMatch プロパティを取得できません。 ----------------------------------------- が出てしまいます。 r = 0 を入力しましたが、どこが間違っていますか?

その他の回答 (5)

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.6

こんにちは。 >いろいろなVBAに関するサイトで「On Error Resume Next」を使用しないほうが良いと書かれていました 今、いくつかのサイトを読んでみました。書いてある内容の多くは一般論ですが、それでは意味はないと思います。 On Error Resume Next というのは、次の行のコマンドや関数の戻り値のエラーをその中だけで回避できるか、という本質的なところに立ち返らない限りは、簡単に利用はしないほうがよいです。そういう私も、最初は分からなかったです。 On Error Resume Nextを入れると、何事もなかったように、次の行に行ってしまうということです。ところが、値を確保していたりすると、前のものがそのまま残っているので、間違った答えが返ってしまいます。 ------------------------------- Sub TestSample3R ()    )   ( On Error Resume Next For i = 1 To Range("B65536").End(xlUp).Row  r = 0  '←ここがミソですね。値をクリアさせる  r = WorksheetFunction.Match(Cells(i, 2), Range("A:A"), 0) -------------------------------- それとは別に、VBAでは、Variant 型は、エラー値という値自体も、入れられるのですが、ただ、WorksheetFunction としてしまったら、エラー値ではなく、実行時エラーが発生してしまうから、戻り値では、エラーを救済できないのです。 ただ、これは、XL2000 以降で、その前までは、 Dim r As Variant  r = Application.Match(Cells(i, 2), Range("A:A"), 0) として、書いていたわけです。そうすると、r には、エラー値が入れられるので、 If r >0 Then の代わりとして、On Error Resume Next を入れずに If IsError(r) Then だけで済みます。 では、なぜ、そう書かないかというと、Microsoft 側では、もう古い書き方を採用していないからです。Application.Match は、特別な使い方です。ただ、一度、こちらも試してみるとよいと思います。

mimoule1998
質問者

お礼

Wendy02様 ご教授ありがとうございました。 On Error Resume Nextの使い方は様々なんですね。 ・エラーが出ないと分からなくなるので使用しない場合 ・エラーが仕様上出てしまうので、使用する場合 ※値がリセットされないと言う事はかなり勉強になりました。 詳細にいろいろと教えてくださり本当にありがとうございました。

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.5

こんにちは。 >r = 0 を入力しましたが、どこが間違っていますか? 良く、サンプルをみてくださいね。 Sub TestSample3R ()   Dim r As Long   Dim i As Long   On Error Resume Next  '←ここの部分が抜けています。   For i = 1 To Range("B65536").End(xlUp).Row     r = 0     r = WorksheetFunction.Match(Cells(i, 2), Range("A:A"), 0)     If r > 0 Then       MsgBox r,vbInformation     End If   Next i   On Error GoTo 0  ←ここの部分が抜けています。 End Sub 「On Error Resume Next」(オン・エラー・レジューム・ネックスト)を、ループの前に入れてあげる必要があるのです。それで、エラーが出ても、次のコードに行くように出来ますね。 そして、Match関数の前に、r = 0 を入れてあったので、0のままになりますから、 If r > 0 Then で、分岐できるわけです。 これで、いかがですか? ただ、まだ、他の部分は見ていませんので、試してみてください。 なお、「On Error GoTo 0」は、慣例的に、On Error Resume Next を入れた後に、そのトラップは終わりました、というステートメントを後のところに入れます。

mimoule1998
質問者

お礼

Wendy02さん お返事が遅くなって申し訳ありません。 「On Error Resume Next」をつけてうまくいきました。 いろいろなVBAに関するサイトで「On Error Resume Next」を 使用しないほうが良いと書かれていましたが、このように 使用しないとうまく動かない事もあるんですね。 本当にありがとうございました。

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.3

こんにちは。 aplication. つづりが違いますし、今の段階では、それは要りません。(それは、方針が決まれば必要ですが、変数の宣言の部分から変わってきます。) namebook は、オブジェクトではありません。Workbooks(namebook) ではないでしょうか? Match の検査値の引数は、値(.Value)ですから、Range("C3:AH3")では違います。配列数式で行うとすれば、WorksheetFunction は使えません。 また、  Worksheets("sheet1").Range("C") このような範囲のRangeオブジェクトの仕方は出来ないと思います。 Range("C:C") か、Columns(3) などだと思います。 WorksheetFunction.Match( と仮に括弧でくくって数式を正しくしても、この数式の変数のr の逃げ場がありません。それで、On Error Resume でトラップを置いても、On Error Resume では、今度は、r の値の更新がされませんので、今のままでは、r > 0 では分岐できる場合は、エラーがなかったときに限ります。エラートラップする場合は r は、必ず、r = 0 としなければなりません。他の逃げ方もあります。一般的に、WorksheetFunction は、エラーを返すものは使い方が難しいです。 With Workbooks.Open(pathmacrobook & namebook) でブックを開いておいて、 If の中で、 With Workbooks.Open(pathmacrobook & namebook) と、もう一度、開こうとしています。 申し訳ありませんが、おやりになろうとしている意味は分かるのですが、ちょっとミスが多すぎますね。 もう少し、変数を増やして、置き換えたら、分かりやすくなると思います。あまり、頭のオブジェクトから書いていくと、それだけ文字数が増えて、見にくくなってしまいます。がんばって、ひとつずつ、見やすく書き直してみてください。必ず、出来るようになるはずです。

mimoule1998
質問者

お礼

Wendy02さん ご回答ありがとうございます。お礼が遅くなってすみません。 考えていたら頭が混乱してきましたので、わからない事を 箇条書きにしてみます。 ・MATCH関数を使うのがナンセンスという事でしょうか? ・Set = DestBook.Worksheets("sheet3").Range("C:C")は ローカルウィンドウを見たところ、大丈夫な気がします。 ・Set = Workbook(namebook).Worksheets("sheet1").Range("C") とすると、ローカルウィンドウでは”Nothing”となっていました。 ・Dim ○ As ○としたときに、オブジェクトがありません。とういう 時は、Workbook()が足りないという事でよろしいでしょうか? 何とか自分の手で完成させたいので、変数を増やすヒントを頂けませんか?

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.2

Match関数の後に引数を示す( は要りませんか。 >WorksheetFunction.MatchThisWorkbook >「Loopに対するDoがありません」とは、私の言うことは無関係のようですが、とりあえず。

  • pbforce
  • ベストアンサー率22% (379/1719)
回答No.1

どの行でエラーがでるのですか?

関連するQ&A

  • EXCEL2000とEXCEL2003のVBAについて

    現在、EXCEL2000で下記のコードを実行しています。 が、EXCEL2003で実行すると、 .UsedRange.Copy myb のコードが実行されているのにコピー出来ていません。 ファイルは開いていて、エラーは出ていないのです。 問題点わかる方教えていただけますか? Sub 日別データ読込() Dim rngsaki As Range Dim pathmacrobook As String Dim namebook As String Dim motobook As Workbook Dim myb As Variant Set rngsaki = Workbooks("残高集計用.xls").Worksheets(3).Range("a2") pathmacrobook = ThisWorkbook.Path & "\CSV読込データ12\" namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set motobook = Workbooks.Open(pathmacrobook & namebook) Set myb = Workbooks("残高集計用.xls").Worksheets(3).Range("A65536").End(xlUp) With motobook.Worksheets("Sheet1") .UsedRange.Copy myb End With motobook.Close False namebook = Dir() Loop MsgBox "完了しました" End Sub

  • 【マクロ】値貼り付けに変更するには…?

    当方Excel2003です。 ○フォルダ内に入力用のブック(複数)とまとめ用ブック(一つ)が存在し ○すべてのブックにはシートが一つしかなく、タイトル行の位置はまとめブック含めすべて同じ構成である ○入力用ブックのシート名は「入力」、まとめ用ブックのシート名は「まとめ」である 前提で、入力用ブックのデータ入力域をまとめ用ブックに順次コピーをしようと作成中のものですが、 以下の構文 Set c = .Range("B" & .Rows.Count).End(xlUp).Offset(1) あるいは With .Worksheets(入力).Range("B3:H3" & Range("H65532").End(xlUp).Row).Copy Destination:=c の部分について コピー貼り付け(そのまま)ではなく、 「値のみの貼り付け」に変更するには? どういうふうに変更したら良いのか どなたかご教示いただければ幸いです。 よろしくお願いいたします。 Sub 連続貼り付け() Dim sFile As String Dim c As Range Dim myPAth As String Application.ScreenUpdating = False sFile = Dir(ThisWorkbook.Path & "\*.xls", vbNormal) myPAth = ThisWorkbook.Path Do While 0 < Len(sFile)      With ThisWorkbook.Worksheets("まとめ")       Set c = .Range("B" & .Rows.Count).End(xlUp).Offset(1)      End With     Select Case sFile        Case ThisWorkbook.Name:        Case Else          With Workbooks.Open(Filename:=myPAth & "\" & sFile, ReadOnly:=True)              With .Worksheets(入力)                  .Range("B3:H3" & Range("H65532").End(xlUp).Row).Copy Destination:=c              End With             .Close SaveChanges:=False          End With      End Select      sFile = Dir()      Set c = Nothing   Loop   Application.ScreenUpdating = True   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

  • ブック内に特定名のシートがある場合

    はじめまして、こんにちは。 VBAを最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 Dim wb As Workbook, myRow As Long Dim e As Integer myRow = ThisWorkbook.Worksheets(1).Rows.Count With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) <> ThisWorkbook.FullName Then Set wb = Workbooks.Open(.FoundFiles(i), UpdateLinks:=0) Application.ScreenUpdating = False ThisWorkbook.Worksheets(1).Range("A" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F6").Value ThisWorkbook.Worksheets(1).Range("B" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F7").Value ThisWorkbook.Worksheets(1).Range("C" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F8").Value ThisWorkbook.Worksheets(1).Range("D" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("Y6").Value wb.Close False End If Next i Else MsgBox "ファイルがありません。" End If End With End Sub

  • 複数ファイルのA1だけを抽出して別ファイルにしたい

    すみませんが、教えてください。 特定のフォルダ内に入っているcsvのA1列目のみ抽出して別ファイルにしたく、検索したところ 同じように困っていた方がいたようで、参考にさせていただいたのですが、 以下を実行しても インデックスが有効範囲にありませんと出ます。 各csvファイルのシート名は 1000近くあるファイル全て違い、別々の名前(コード00-000とか)になっています。 (エクセルで開いたとき) お手数ですが、教えていただきたくお願いいたします。 参考にしたマクロです。 Sub macro1() Dim myPath As String Dim myFile As String myPath = "ファイルの場所\" myFile = Dir(myPath & "*.xls") Do Until myFile = "" Workbooks.Open myPath & myFile With Workbooks("集約.xls").Worksheets("Sheet1").Range("A65536").End(xlUp) .Offset(1, 0).Value = myFile .Offset(1, 1).Value = Workbooks(myFile).Worksheets("概要").Range("C3").Value End With Workbooks(myFile).Close savechanges:=False myFile = Dir() Loop 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

  • Excel マクロ 別ブックの情報をコピーする方法

    他のブックの情報をコピーして貼り付けるマクロを作成しています。 2種類のブックから情報をコピーして貼り付けます。 Sub MailTemp() Dim myCellall As Range Dim myCellyoso As Range Dim myCellfor As Range Set myCellall = Sheets("すべて").Range("A3") With Workbooks.Open("\") With .Worksheets("すべて") .Range(.Range("A3"), .Cells.SpecialCells(xlCellTypeLastCell)).Copy myCellall End With .Close False End With Set myCellyoso = ThisWorkbook.Worksheets("予測").Range("A3") Set myCellfor = ThisWorkbook.Worksheets("結果").Range("A3") With Workbooks.Open("\別ブック") With .Worksheets("予測") .Range(.Range("A3"), .Cells.SpecialCells(xlCellTypeLastCell)).Copy myCellyoso End With With .Worksheets("結果") .Range(.Range("A3"), .Cells.SpecialCells(xlCellTypeLastCell)).Copy myCellfor End With .Close False End With End Sub 下記の箇所でエラーが発生して、先に進みません。 原因を調べていましたが、わかりません。 Set myCellfor = ThisWorkbook.Worksheets("結果").Range("A3") エラーメッセージ 実行時エラー'9' インデックスが有効範囲にありません。 アドバイスを頂けますでしょうか。 よろしくお願いいたします。

  • VBAの繰りかえし処理について

    workbook1(以下wb1)のB3に入力した県名を含む行を、 workbook2から取り出し、wb1のB7以降に表示させたいと思っています (ちなみに県名はwb2のC列に入っています) 同じ県名が含まれる行が多いので、それらを繰り返し処理で 全て書き出したいと思い、以下のマクロを作りました。 Sub macro3() Dim c Dim wb1 As Workbook Dim wb2 As Workbook Dim k As Integer Dim firstAddress As String Application.ScreenUpdating = False Set wb1 = ActiveWorkbook Set wb2 = Workbooks.Open("G:\zyouhousyori\inn100best_full.csv") Set c = cell.Find(What:=Range("B3").Value) With wb2.Worksheets(1).Range("A1:A100") If Not c Is Nothing Then firstAddress = c.Address Do Set c = cell.FindNext(c) For k = 0 To 10 .Range("C100").End(xlUp).Offset(1).Copy _ wb1.Worksheets("sheet1").Cells(7 + k, 2) Exit For ★Loop While Not c Is Nothing And _ c.Address <> firstAddress End If End With Application.ScreenUpdating = True wb2.Close False End Sub しかし、実行すると★マークのついた所でエラーになってしまいます (対応するDoがありません、と出ます) VBA初心者なので、どこがどう違うのかいまいちわかりません; アドバイスお願いします。

  • 複数のエクセルファイルとシートからデータ抽出したい

    以前に http://soudan1.biglobe.ne.jp/qa8369459.html でやられている内容なのですが、私の場合はシートすべての[i4」のセル値を一覧でひっぱりたいです。 keithinさんご回答の sub macro1()  dim myPath as string  dim myFile as string  dim w as worksheet  mypath = thisworkbook.path & "\"  myfile = dir(mypath & "*.xls*")  application.screenupdating = false  do until myfile = ""   if myfile <> thisworkbook.name then    workbooks.open mypath & myfile    for each w in workbooks(myfile).worksheets    with thisworkbook.worksheets("Sheet1").range("A65536").end(xlup).offset(1)     .value = myfile     .offset(0, 1) = w.name     .offset(0, 2).value = w.cells(w.rows.count, "C").end(xlup).value              ↑をRange("i4").Value      end with    next    workbooks(myfile).close false   end if   myfile = dir()  loop  application.screenupdating = true end sub にて実施しましたが、ファイル名・シート名は正確に抽出するものの 参照したい「i4」のデータが先頭のシートのi4だけを拾ってしまいます 1.xls、2.xls、3xlsがありそれぞれ名前がばらばらなシート「あ」、「い」、「う」の3つがある。2.xlsには「え」、「お」、「か」のしーとがあると仮定、マクロを実行すると、一覧のエクセルに 1、xls  あ  あのシートi4の値 1、xls  い  あのシートi4の値 1、xls  う  あのシートi4の値 2.xls  え  えのシートi4の値 2.xls  お  えのシートi4の値 2.xls  か  えのシートi4の値 子のようなか形で出力されます い のところには いのシートのi4が、う のところには うのシートのi4が、 抽出されるには構文をどう買えればよいのでしょうか

  • エクセルVBA フォルダ内のどんなシート名であっても読み込みたい

    フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub

専門家に質問してみよう