VBAでB.xlsの番号と同じ番号がD.xlsにあればくっつけたい

このQ&Aのポイント
  • VBAでB.xlsの番号と同じ番号がD.xlsにあればくっつけたいという要件があります。エクセル関数のVlookUPを使用したいが、1004エラーが発生しています。
  • 必要な部分を抜き出していますが、エラーが発生しているため、解決方法を教えていただきたいです。
  • 詳細な説明が不十分なため、初心者向けの説明をお願いします。
回答を見る
  • ベストアンサー

VBAで B.xlsの番号と同じ番号がD.xlsにあればくっつけたい

VBAで B.xlsの番号と同じ番号がD.xlsにあればくっつけたい  エクセル関数でいうとVlookUPをしたいのですが、1004エラーがかかってしまいます。 必要なところだけを抜き取っているので、分かりにくいかと思いますが、   Dim a, b, c, d, y, x, z, i, j, k, m, n, o, r As Long a = 2 '2 なのは、A2から数えるため。 b = 0 'BookBのレコードの数を数えるための変数。 Do While Workbooks("B.xls").Worksheets("Sheet1").Cells(a, 1) <> "" a = a + 1 b = b + 1 Loop Workbooks("B.xls").Activate For k = 2 To b For m = 2 To 300000 エラー⇒ If Workbooks("B.xls").Worksheets("Sheet1").Cells(k, 1) = Workbooks("D.xls").Worksheets("Sheet1").Cells(m, 1) Then Workbooks("B.xls").Worksheets("Sheet1").Cells(k, 12) = Workbooks("D.xls").Worksheets("Sheet1").Cells(m, 2) Workbooks("B.xls").Worksheets("Sheet1").Cells(k, 13) = Workbooks("D.xls").Worksheets("Sheet1").Cells(m, 3) End If Next m Next k   ・   ・   ・ の部分でつまっています><; 説明が不十分でしたら追加いたしますので、初心者の簡単なエラーだとは思うのですが、教えてください<(__)>

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

  • ベストアンサー
  • myRange
  • ベストアンサー率71% (339/472)
回答No.1

エラー番号だけはなく、エラーのメッセージも表示すべきでしょう。 ま、それは置いといて、、、、 エクセルのバージョンは、2007より前(2003とか)を使ってませんか? 使ってますよね? >For m = 2 To ▼300000▼ この300000がエラーの原因です。 最大65536です。(因みに、2007以上は、100万以上)   で、どのバージョンでも使えるようにデータの最終行を求めて処理するといいでしょう。 '------------------------------------------- Dim LastB As Long '●B.xlsのA列データ最終行 Dim LastD As Long '●C.xlsのA列データ最終行 LastB = Workbooks("B.xls").Sheets("Sheet1").Cells(Cells.Row, 1).End(xlUp).Row LastD = Workbooks("D.xls").Sheets("Sheet1").Cells(Cells.Row, 1).End(xlUp).Row For k = 2 To LastB   For m = 2 To LastD  ==以下質問書のコード== '----------------------------------------- 以上です。  

RENTAOSAKA
質問者

お礼

ありがとうございます。 次回よりエラーメッセージも記載します><;すみません。。。 最終行の求め方までありがとうございます。 確かにエクセル2000を使ってます^^; 計算をすれば、時間もかからないですし、いけました<(__)> 計算を考えずズボラをして適当な上限をいれたのが間違いだったようですね><; ありがとうございました<(_ _)>

関連するQ&A

  • Excel VBA .xlsm→.xls変換

    VBAマクロの初心者です。 Office2010で作ったプログラムをOffice2000で実行したいのですが、 *.xlsmなら問題なく実行できるプログラムが、*.xlsでは 「エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。」となります。作ったプログラムの詳細は以下の通りです。 *.xlsmで実行した際も、繰り返しが多いせいかどうも遅いので、効率化できる方法がありましたら、併せてご教授いただけると幸いです。 よろしくお願いいたします。 目的:Sheet1にある表AをSheet2にある表Bに変換する。(添付画像参照)    ※年月と国名は、あらかじめSheet2に入力してあります。     また、空白にゼロを入れる作業は省いています。 以下、実行したプログラムです。 Sub paste() Dim name11 Dim name12 Dim name13 Dim name21 Dim name22 Dim name2k For i = 2 To 150 'Sheet1の行はiで定義し、2行目から150行目まで繰り返し For j = 2 To 300 'Sheet2の行はjで定義し、2行目から300行目まで繰り返し name11 = Worksheets("Sheet1").Cells(i, 1).Value 'Sheet1の"年" name12 = Worksheets("Sheet1").Cells(i, 2).Value 'Sheet1の"月" name13 = Worksheets("Sheet1").Cells(i, 3).Value 'Sheet1の"国名" name21 = Worksheets("Sheet2").Cells(j, 1).Value 'Sheet2の"年" name22 = Worksheets("Sheet2").Cells(j, 2).Value 'Sheet2の"月" For k = 3 To 100 'Sheet2の列はkで定義し、3列目から100列目まで繰り返し name2k = Worksheets("Sheet2").Cells(1, k).Value 'Sheet2の1行目(国名)※*.xlsで実行し、デバッグすると、この行がエラー1004になります。 If (name11 = name21 And name12 = name22 And name13 = name2k) Then '年と月が一致し、かつSheet1の3列目(国名)とSheet2の1行目(国名)が一致したら Worksheets("Sheet1").Cells(i, 4).Copy Destination:=Worksheets("Sheet2").Cells(j, k) 'Sheet1のi行4列目の"量"を、Sheet2のj行k列に貼り付ける。 '(j行は正しい年月の横、k列は正しい国名の下。) Exit For '検索→貼り付けのループを抜けて最初に戻る。 End If Next Next Next End Sub

  • エクセルVBAについて

    前回質問させていただきました件の追加機能になります。以前質問させていただきましたマクロが下記のものです。 Sub TESTa() Dim A As Long Dim B As Long Dim C As Long Dim D As Long Dim E As Long Dim F As Long '表の行数を調べる A = Worksheets("sheet1").Range("C65536").End(xlUp).Row - 1 For C = 1 To A For B = 4 To 7 'Sheet1のデータをSheet2に複写する Worksheets("Sheet2").Cells(B - 3 + D, 15) = Worksheets("Sheet1").Cells(C + 1, 1) Worksheets("Sheet2").Cells(B - 3 + D, 6) = Worksheets("Sheet1").Cells(C + 1, B) Worksheets("Sheet2").Cells(B - 3 + D, 14) = Worksheets("Sheet1").Cells(C + 1, 3) Worksheets("Sheet2").Cells(B - 3 + D, 10) = Worksheets("Sheet1").Cells(1, B) Worksheets("Sheet2").Cells(B - 3 + D, 13) = Worksheets("Sheet1").Cells(C + 1, 2) Next D = C * 4 Next 'Sheet2の表の行数を調べる Sheets("Sheet2").Select E = Worksheets("sheet2").Range("F65536").End(xlUp).Row '0欄の確認 For F = E To 1 Step -1 If Worksheets("Sheet2").Cells(F, 6) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Next End Sub カウントするとデータ個数がSheet1で約120件になりSheet2においては、4倍になりますので約480件になります。 そこで Sheet1において12件ごとに、Sheet2,3,4...としたいのです。 Sh1 NO.1~12がSheet2 Sh1 NO.13~24がSheet3 ... 10枚のシートにしたいのですが、このマクロにどのような命令を加えればよろしいでしょうか? お手数ですがよろしくお願いいたします。

  • 横にコピーするには・・。

    教えてください・・。 01.xls・02.xls・03.xlsとあり、その中のシート(01・02・03)をコピーして、全部というシートにまとめたいと思っています。 列にデータを追加したいのですが、行にデータが追加されてしまいます・・。 どうしたらいいのか教えてください。 01のシートがAからDまで 02のシートがEからGまで 03のシートがHからLまで とコピーをしたいと思っています・・。 --------- PathName = ThisWorkbook.Path & "\" ArrBook = Array("01.xls", "02.xls", "03.xls") For i = LBound(ArrBook) To UBound(ArrBook) Workbooks.Open PathName & ArrBook(i) Next Set WS(1) = Workbooks("01.xls").Worksheets("01") Set WS(2) = Workbooks("02.xls").Worksheets("02") Set WS(3) = Workbooks("03.xls").Worksheets("03") Set WS(4) = ThisWorkbook.Worksheets("全部") With WS(4) .Cells.ClearContents .Cells(1, 1) = "A" .Cells(1, 2) = "B" .Cells(1, 3) = "C" .Cells(1, 4) = "D" .Cells(1, 5) = "E" .Cells(1, 6) = "F" .Cells(1, 7) = "G" .Cells(1, 8) = "H" .Cells(1, 9) = "I" .Cells(1, 10) = "J" .Cells(1, 11) = "K" .Cells(1, 12) = "L" .Cells(1, 13) = "M" .Cells(1, 14) = "N" .Cells(1, 15) = "O" .Cells(1, 16) = "P" .Cells(1, 17) = "Q" LastRow(1) = WS(1).Range("A65536").End(xlUp).Row LastRow(2) = WS(2).Range("A65536").End(xlUp).Row LastRow(3) = WS(3).Range("A65536").End(xlUp).Row For i = 1 To 3 LastRow(4) = .Range("A65536").End(xlUp).Row + 1 WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1) LastRow(4) = .Range("A65536").End(xlUp).Row End With For i = LBound(ArrBook) To UBound(ArrBook) Workbooks(ArrBook(i)).Close SaveChanges:=False Next End Sub

  • vba ;制御

    下記でhakkenn = 1 '******** のところから次は next iの直前にいくようにプログラムをランさせるにはどう記述すればよいか。 よろしくお願いします。 For i = 3 To d hakken = 0 For ui = CELL_S To (CELL_E - CELL_S + 1) If Worksheets("sheet2").Cells(i, "D") = Worksheets("user").Cells(ui, "A") Then Worksheets("user").Cells(ui, ichi) = "◎" hakkenn = 1 '******** Else End If Next ui If hakkenn = 1 Then Else Worksheets("user2").Cells(ui, "D") = Worksheets("sheet2").Cells(i, "D") End If Next i

  • VBAプログラミングの質問です。

    Sheet1の第2列に行番号、4列に列番号、5列にそこの値が書かれたデータが並んでいます。 1 1 967 2 1 687 ……… x y 802 ……… x行、y列に802を代入するという感じです。全部で57985データあります。 前の回答を参考にして、48881データまではSheet2に For k = 1 To 48881 Worksheets("Sheet2").Cells(1 + Worksheets("Sheet1").Cells(k, 2), 1 + Worksheets("Sheet1").Cells(k, 4)) = Worksheets("Sheet1").Cells(k, 5) Next k このようにプログラムを書いて納まって、残りの57985-48881=9104データの行列はSheet2に納まらなかったので、Sheet3に書こうと思い、下のように書きましたがプログラムがうまく動きませんでした。他にも試しましたが初心者のためダメでした。 Dim n As Long Dim m As Long n = 9104 m = 48881 For k = 1 To n Worksheets("Sheet3").Cells(1 + Worksheets("Sheet1").Cells(k + m, 2), 1 + Worksheets("Sheet1").Cells(k + m, 4)) = Worksheets("Sheet1").Cells(k + m, 5) Next k 48881というのが大きいため動かないと考えられますが、どのように対処したらよいかわかりません。教えてください。お願いします。

  • EXCEL VBA エラーメッセージ「「Moveメソッドに失敗しました」の対応方法

    いつも拝見しています。 あるブック(A.xls)にある10個のシートのうち"Sheet1"以外のシートを別のブック(B.xls)に移動しようとしたところ「Moveメソッドに失敗しました」とエラーが出てしまいました。 何が原因なのか見当がつきません。 このメッセージを過去ご覧になった方がいらっしゃいましたら、どのように対応されたか教えてください。よろしくお願いします。 以下が考え中のソースです。///////////////////// 'ケースに移動する(今はコピー) Dim cnt As Integer cnt = 0 For Each pWS In Workbooks("A.xls").Worksheets If pWS.Name <> "Sheet1" Then pWS.Move after:=Workbooks("B.xls").Sheets(cnt+1) cnt = cnt + 1 End If Next

  • 番号を振るvbaで悩んでいます。

    本を読みながら作ったのですが、全然動いてくれません。 Sheet1に A           B 1 2開始日      2月12日 3開始時間     8:30 4終了時間     12:00 5間隔/ 分      5 6人数/コマ      8 という情報が入っています。 Sheet2には A2から番号が振ってあります。2000件くらいあります。 それに次の条件で番号を振りたいのです。 8時30分から12時までの間で8人毎に5分間下記の時間を振り分けたいのです。 12時を過ぎると翌日の8時半からまた同じことを繰り返します。 Sheet1の情報は毎回変更しますので、変数を使いたいと思っています。      A     B     C 1 2    1001  2/12   8:30 3    1002  2/12   8:30 :      :    :      : :     1008  2/12   8:30 :     1009  2/12   8:35 :     1010  2/13   8:35 :      :    :      : :      :    :      : :     1336  2/13   8:30 :      :    :      :     Sub test() Dim strdate As Date, strtime As TimeValue, endtime As TimeValue Dim i As Long, c As Long, j As Long strdate = Worksheets(2).Range("b2").Value strtime = Worksheets(2).Range("b3").Value = TimeValue("8:30") endtime = Worksheets(2).Range("b4").Value = TimeValue("12:00") Range("b:b").NumberFormatLocal = "h:mm" i = Worksheets(2).Range("b5").Value c = Worksheets(2).Range("b6").Value If strtime < endtime Then Do While strtime < endtime For j = 1 To c Worksheets(1).Cells(j, 0) = strdate Worksheets(1).Cells(j, 1) = strtime Next j strtime = DateAdd("m", 5, strtime) Loop Else strtime = Worksheets(2).Range("b3").Value Do Until strtime = endtime For j = 1 To c Worksheets(1).Cells(j, 0) = strdate + 1 Worksheets(1).Cells(j, 1) = strtime Next j strtime = strtime + 5 Loop End If End Sub これでは全く動きませんでした。 また、strtimeをtimevalueで宣言するとオブジェクトを要求され、結果変数ではなく 直接データを入れることになってしまい、目的を果たせません。 初心者がやることではないなと思いましたが、これが出来ると、私たちの仕事が 画期的に向上するので、是非今回は苦労しても作り上げたいと思いました。 プロの方々はこういう場合、私はIf ⇒Do Loop⇒For Nextをネストしましたが、 どういう風に考えられるのでしょうか?それも興味があります。 よろしくアドバイスお願いします。<m(_ _)m>  

  • エクセルVBA 呼出し

    エクセルVBA 呼出し FormをひらいてTextBox31に数字(ID番号)が入り それをSheet”計”のF4に入れます! そのF4を他のブックの WSName = "DATA.xls"にて IDを検索して、名前や色々なものをSheet”計”に写します。 それを再度、FromのそれぞれのTextBoxに入れます。 しかし、SH1.Cells(lngNumber, 2) = Worksheets("計").Range("B2").Value '名前 が上手くできません!!エラー表示などはないのですが… DATA.xlsにはID番号があるのですが、それを入力しても値が入りません どこの部分が間違っているのか? すいません、教えてください WSName = "DATA.xls"を呼出す記述は省略!! 'DATA.xlsとSheet1をセットする。 Set WS = Workbooks(WSName) Set SH1 = WS.Worksheets("Sheet1") 'ブックが存在していないのであればメッセージを出し処理を抜ける。 Else MsgBox WDName & "が存在していません。設置してください。", vbExclamation, "確認してください" Exit Sub End If flag = False For lng = 1 To lngYcnt_K '計のF4と同じ値を見つけてテキストボックスの値を入力。 If CStr(Worksheets("計").Range("F4").Value) = CStr(SH1.Cells(lng, 1)) Then flag = True lngNumber = lng Exit For End If Next lng If flag = True Then SH1.Cells(lngNumber, 2) = Worksheets("計").Range("B2").Value '名前 With Worksheets("計") ’計のSheetの値を開いているFromのTextBox4に再度値を入れる TextBox4.Value = .Range("B2").Value '計のSheetからTextBox1の値の名前’ End With MsgBox " 記録を呼び戻しました" Else TextBox31.Value = "確認必要" End If

  • エクセルVBA!(COPY) Win2000,offce2000

    単純な質問かもしれませんが、 WorkBooks("test")から 別のWorkBooks("Data").WorkSheets("Sheet1")のデータの数を判定して全てをコピーして、 WorkBooks("test")のWorkSheets("Sheet2")へペーストしたいのですが、うまくいきません ↓のような感じです。 Dim wstest As Worksheet Dim wsData As Worksheet Dim wsNM As String Dim Drow As Long Sub copy() 'DataSheetのSheet名がその都度違うので、取得しました。 wsNM = wsData.Sheets(1).Name Set wsData = Workbooks("Data.xls").Worksheets(wsNM) Set wsTest = Workbooks("Test.xls").WorkSheets("Sheet2") 'データの範囲判定 Drow = wsData.Range("H65536").End(xlUp).Row '/////// ここからが???です /////// wsDataのA1からBAのDrowを範囲を指定して、Copy → wsTestのA1に貼り付けたいのですが、どうしたらよいのでしょうか? コピーしたり、直接書くようにしたりといろいろなコードを書いてみましたがダメでした。 Cellsで範囲をとる方法がわかりません。Rangeなら(A1:BA300)のように取れる範囲もCellsの時はどうしたらよいのでしょうか?(そのまま書けば、Cells(1,1):Cells(Drow,53)みたいな・・・・・) と、悩んでいるより一気にコピーするのもどうかと思いFor~Nextで1行ずつ書いていったらどうかとも考えましたが、うまくいきませんでした。 End Sub ※ Drowは、6000~20000 よろしくお願いします。

  • Excel VBAで他のワークブックからのコピぺの仕方について

    Excel VBAで開いている全てのワークブックから決められたセルの中身とそのシート名をそれぞれ決められた一つのワークブックにコピぺする マクロを作りたいのですが、どうやって作って良いのかが分かりません。 例えば、 Sub Mac() For i = 1 To 100 Workbooks("Book1.xls").Worksheets("sheet1").Range(Cells(2108, 2), Cells(3108, 2)).Cut Destination:=Workbooks("Book1.xls").Worksheets("sheet1").Cells(13, 2) End Sub みたいにすれば良いと思うのですが、開いている全てのファイルからのコピぺってどうやって記述するのでしょうか? 何卒よろしくお願い致します。

専門家に質問してみよう