• 締切済み
  • すぐに回答を!

Excel VBA 別ブックへの登録

お世話になります。 今お仕事でExcelのVBAで同じフォルダ内の別ブックにデータを書き込みたくて いろいろやって見たのですが、上手くできません。 お力を頂ければと・・・・ <詳細> やりたいこと サーバー内に各個人の見積フォルダがあり、そのフォルダの中に見積作成と見積データの各ファイルが2つあります。 見積作成で作成したデータが登録ボタン(VBA)により見積データに登録されるようにしたい。 今までは同じブック内の別シートへデータを登録していました。 今回は同じフォルダ内の別ファイルへのデータ登録です。 ここまではできました・・・・ Sub 見積データ取得() Dim wSheet As ThisWorkbook Dim idx As String 'データ保存用シートを取得 Workbooks.Open Filename:=ThisWorkbook.Path & "見積データ.xls" Set wSheet = ThisWorkbook.Sheets(見積作成.xls) '空白行を取得 idx = CStr(wSheet.UsedRange.Row(wSheet.UsedRange.Rows.Count).Row + 1) '明細を取得 Dim wRange As Range Set wRange = ThisWorkbook.Sheets("見積作成").Range("B7:Q175") Dim i As Integer For i = 1 To wRange.Rows.Count If wRange.Cells(i, 6).Value <> "" Then '作成日 wSheet.Range("A" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H2").Value '見積NO wSheet.Range("B" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H5").Value '見積名 wSheet.Range("C" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C1").Value '提出先NO wSheet.Range("D" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("B3").Value '提出先 wSheet.Range("E" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C3").Value '提出先フリガナ wSheet.Range("F" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("Y5").Value '担当者 wSheet.Range("G" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("H1").Value '備考欄 wSheet.Range("S" & idx).Value = ThisWorkbook.Sheets("見積作成").Range("C31").Value 'メーカー名 wSheet.Range("H" & idx).Value = wRange.Cells(i, 10).Value '商品NO wSheet.Range("I" & idx).Value = wRange.Cells(i, 1).Value '商品名 wSheet.Range("J" & idx).Value = wRange.Cells(i, 2).Value '入数 wSheet.Range("K" & idx).Value = wRange.Cells(i, 9).Value '数量 wSheet.Range("L" & idx).Value = wRange.Cells(i, 3).Value 'A価 wSheet.Range("M" & idx).Value = wRange.Cells(i, 5).Value '金額 wSheet.Range("N" & idx).Value = wRange.Cells(i, 6).Value 'C価 wSheet.Range("O" & idx).Value = wRange.Cells(i, 14).Value 'D価 wSheet.Range("P" & idx).Value = wRange.Cells(i, 16).Value '数量 'wSheet.Range("K" & idx).Value idx = CStr(CInt(idx) + 1) End If Next でも上手くいきません・・・ よろしくお願いいたしますm(_ _)m

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

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

みんなの回答

  • 回答No.1

Set wSheet = ThisWorkbook.Sheets(見積作成.xls) ↓ Set wSheet = ThisWorkbook.Sheets("見積作成") って言うミスしか気付かなかった。

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

質問者からのお礼

ありがとうございます。 見積作成の記述は直しました・・・ でも、まだエラーがでてしまいました(´;ω;`) メソッドまたはデータメンバーが見つかりません・・・っとでてしまいました。 idx = CStr(wSheet.UsedRange.Row(wSheet.UsedRange.Rows.Count).Row + 1) この記述のUsedRangeこの記述が青くなっていました。 お分かりになる方がおりましたら 助けていただけると幸いです・・・ヽ(´Д`;)ノm(_ _)m また、

関連するQ&A

  • excel  vba  シートの取り扱い

    Sub   aaa() Worksheets.Add ActiveSheet.Name = "Namefile" ((質問)ここへ適当なコードを追加することによって 以下のThisWorkbook.Sheets(1)というのを、上で追加した Namefileシートを処理することとしたい。 つまり  Namefileシート=ThisWorkbook.Sheets(1) どうすればいいか。よろしくお願いします。) ThisWorkbook.Sheets(1).UsedRange ThisWorkbook.Sheets(1).UsedRange.Delete ThisWorkbook.Sheets(1).Range("B2") = "ファイル名" ThisWorkbook.Sheets(1).Range("C2") = "最終更新日" End Sub

  • 他ブックへの書き込みについて

    MyR2=ThisWorkbook・・・・のところでデバックします。エラーメッセージは、オブジェクト変数または With ブロック変数が設定されていません。(Error 91) 解決方法ご教示下さい。 Sub 報告() Dim MyR1 As Long Dim MyR2 As Long MyR1 = 4 For i = 1 To 14 If Cells(MyR1, 5).Value <> "" Then MyR2 = ThisWorkbook.Sheets("共用部点検報告書").Columns("A").Find(Cells(MyR1, 5).Value, _ lookat:=xlWhole, MatchCase:=True).Row ThisWorkbook.Sheets("報告書").Cells(MyR2, 6).Value = Cells(MyR1, 4).Value End If MyR = MyR + 3 Next ThisWorkbook.Sheets("報告書").Activate End Sub

  • Excel VBAデータ登録のスピードアップしたい

    下記のようなコードがあります。 ■input データ閲覧・登録・編集シート ■data データを格納するシート inputシートとdataシートでdataの受け渡しを行っているのですが、データレコードを切り替えるだけで20秒ちょっとかかるため、作業効率が悪いです。 この時間を1&#65374;2秒ぐらいまで減らすには、どのように修正すれば、いいでしょうか?どうかアドバイスをお願いいたします。 Private Sub datatouroku() ’データを登録する Dim touroku As Integer Dim fRange As Range Set fRange = Sheets("data").Columns(1).Find(What:=Range("BC1").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) touroku = fRange.Row '検索されたNoの行位置を求める Sheets("data").Cells(touroku, 1).Value = Range("BC1:BE1").Value Sheets("data").Cells(touroku, 2).Value = Range("AX1").Value Sheets("data").Cells(touroku, 3).Value = Range("I4").Value   '・・・上記のデータが全部で256件あります。 End Sub &#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293;&#65293; Private Sub hyouji() 'データを表示させる Dim fRange As Range Dim kensaku As Long Set fRange = Sheets("data").Columns(1).Find(What:=Range("BC1").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)    If (fRange Is Nothing) Then '見つからなかった?    MsgBox "入力された顧客コードが存在しません。", vbExclamation    Exit Sub    End If    kensaku = fRange.Row '検索された顧客DCの行位置を求める     Range("BC1:BE1").Value = Sheets("data").Cells(kensaku, 1).Value     Range("AX1").Value = Sheets("data").Cells(kensaku, 2).Value    Range("I4").Value = Sheets("data").Cells(kensaku, 3).Value     '・・・上記のデータが全部で256件あります。 Set trg = Sheets("data").Cells(kensaku, 1) End Sub

  • エクセルVBAで

    登録ボタンを作りたいのですが うまくいきません。 応答無しになってしまいます。 仕事でコードを入力して、住所やその他の関連事項を 登録して、検索し、封筒に宛名印刷し、登録内容の修正をしたいと思っています。 登録ボタンは下記のようなものを作りました。 Private Sub CommandButton1_Click() Dim bk As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim cnt1 As Long Set bk = ThisWorkbook Set sh1 = bk.Worksheets("現場登録検索") Set sh2 = bk.Worksheets("一覧") cnt1 = 6 Do While sh2.Cells(cnt1, 2).Value <> "" cnt = cnt1 + 1 Loop '得意先CD sh2.Cells(cnt1, 2).Value = sh1.Cells(2, 3).Value '現場CD sh2.Cells(cnt1, 3).Value = sh1.Cells(3, 3).Value '送り方 sh2.Cells(cnt1, 22).Value = sh1.Cells(4, 3).Value '封筒 sh2.Cells(cnt1, 23).Value = sh1.Cells(5, 3).Value MsgBox "登録できました。" End Sub 何が悪いのでしょうか? よろしくお願い致します。

  • 変数を名前に使ったシートにデータをコピーする方法

    いつもお世話になります。 hisworkbookにあるVBAから新たに開いたmyFileにデータをコピーさせようとしています。 myFileである統合.xlsにはあらかじめ該当するシートが作成されています。 myBushoとmyGroupはそれぞれセルの値を参照しています。 それを元に対応するシート名にデータのコピーをしたいのです。 当初workbooks(myFile)をactiveworkbookにしていたのですが、うまくコピーされなかったので、 ファイルパスを記述しました。 sub test() dim cnt as long dim lcnt as long dim myFile as string dim myBusho as string dim myGroup as string cnt = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row lcnt = ActiveWorkbook.Sheets(myBusho & "_" & myGroup).Cells(Rows.Count, 1).End(xlUp).Row myFile = "C:\統合.xls" myBusho = range("A1").value myGroup = range("A2").value ThisWorkbook.Sheets("Sheet1").Range(Cells(9, 1), Cells(cnt, 21)).Copy _ Workbooks(myFile).Sheet(myBusho & "_" & myGroup).Cells(lcnt + 1, 1) end sub 上記のコードではうまくコピーできませんでした。 よろしくアドバイスのほど、お願いします。

  • エクセルVBAを教えて下さい

    エクセルの表で -AB C D E F 1年月--1801 2------ 3------ 4------ (-)は空欄でセルE1=18、F1=1とします。 コントロールボックスをつかって Private Sub Command登録_Click() Dim d1 As Long Dim d2 As Long Dim ret As Variant Dim FindValue As String Dim TotalAddress As String If Range("E1").Value = "" Or Range("F1").Value = "" Then MsgBox "該当する場所にデータが入っていません。", vbCritical Exit Sub End If d1 = Range("A65536").End(xlUp).Offset(1).Row d2 = Range("B65536").End(xlUp).Offset(1).Row FindValue = """" & Range("E1").Value & Range("F1").Value & """" TotalAddress = Range("A1").Resize(d1).Address & "&" & Range("B1").Resize(d1).Address ret = Evaluate("MATCH(" & FindValue & "," & TotalAddress & ",0)") If IsError(ret) Then Cells(d1, 1) = Range("E1").Value Cells(d2, 2) = Range("F1").Value Else MsgBox "既に同じ組み合せがあります。", vbInformation End If End Sub というものを作ったのですが、E1=18、F1=1及びコマンドボタンを別シートに作成し、上記の表への登録をできるようにしたいのですが、なにかいい方法はありませんか?

  • EXCEL VBAの配列でわかりません。

    こんなコードがあるのですが、最後の他のシート(作業中シート)に書き込もうとするとエラーになってしまいます。”Sheets("作業中").”を抜くと同じシートに結果は返ってくるのですが…。コードの内容は、ある範囲のある列から空白ではないセルを探し出してその行のデータを配列で汲み取り、他のシートに一括で洗い出すというものです。 Sub 作業中() Dim myRow As Long Dim Data As Variant Dim WC() As Variant Dim WCE() As Variant myRow = Range("H1").CurrentRegion.Rows.Count Data = Range("H1:M" & myRow).Value For i = 1 To myRow If Data(i, 5) <> "" Then a = a + 1 Else b = b + 1 End If Next ReDim WC(a) ReDim WCE(b) c = 0 d = 0 For i = 1 To myRow If Data(i, 5) <> "" Then WC(c) = Range("H" & i & ":K" & i).Value c = c + 1 Else WCE(d) = Range(Cells(i, 8), Cells(i, 11)).Value d = d + 1 End If Next For i = 0 To a Range(Cells(i + 1, 15), Cells(i + 1, 18)).Value = WC(i) Next For i = 0 To b Range(Cells(i + 1, 19), Cells(i + 1, 22)).Value = WCE(i) Next e = Range(Cells(1, 15), Cells(a, 18)).Value Sheets("作業中").Range(Cells(1, 1), Cells(a, 4)).Value = e End Sub ちなみに同じシートから↓のコードを実行するとうまくいきます。 なぜ~??わからな~い??おしえてくださーい!! Sub test() Dim a As Variant a = Range("H1:K4") Sheets("作業中").Range("N1:Q4") = a End Sub

  • エクセルVBAでTransposeの不思議

    MS Officeのエクセル2000です。 下記Sub test01はRange("A1:I1")に文字列を入力し、一旦配列に取り込んでからワークシートに貼り付けるものです。 試験用のコードですので意味はありません。 このコードで255文字まではまったく問題はありません。 ところが、256文字以上の場合、横に貼り付けは問題ないのですが、 Transposeで縦に変換すると型が一致しません。(Error 13)となります。 どうしてでしょうか? 試行錯誤の結果、Sub test02のように一旦横に貼ったデータをコピーしてTransposeして貼り付けるのは大丈夫のようですので不思議でしょがありません。 またこの方法は列数256より要素が多い配列には使えないので解決策にはなりません。 ご教示くださいませ。 Sub test01() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A5").Resize(UBound(myAr, 2)).Value = Application.Transpose(myAr) '256文字の場合エラー End With End Sub Sub test02() Dim myAr As Variant Dim i As Integer, n As Integer n = 256 '文字数 With ActiveSheet .UsedRange.ClearContents For i = 1 To 9 .Cells(1, i).Value = Application.Rept(Left(.Cells(1, i).Address(0, 0), 1), n) Next myAr = .Range("A1:I1").Value .Range("A3").Resize(, UBound(myAr, 2)).Value = myAr .Range("A3").Resize(, UBound(myAr, 2)).Copy .Range("A5").PasteSpecial Paste:=xlValues, Transpose:=True '256文字の場合もOK Application.CutCopyMode = False End With End Sub

  • Excel VBA 複数のブックの複数シートから

    Excel VBA 複数のブックの複数シートからデータをコピーするマクロを作成したのですが、 コピー部分が上手く作動せず、訳の解らないデータが貼り付いてしまいます。 ちゃんとファイルは読み込んでいます。 、 VBA超初心者なので、うまく動作しませんでした。 どこが悪いのか教えて頂けないでしょうか。 やりたいことは ・同一フォルダ内に複数のExcelファイルがある ・各ファイル内には複数のシートがあり、シート数はファイル毎にばらばら ・各シートの構造は全て同じ ・VBAを保存してあるExcel(貼り付け用.xls)も同じフォルダに置いて作業します ・JEまとめ.ファイルの原本シートをコピーして、シート名に日付を入れたシートに ・全シート下記のセルのコピー(値、縦横変換)を日付をいれた原本コピーのシートに B1&#65374;3セル→A&#65374;C B4&#65374;5セル→G&#65374;H B6セル→J J22&#65374;24→D&#65374;F をシートの一番最初の行は見出しなので、その後上から順に値の貼付けをしたいのです。 エクセルは2003です。 宜しくお願いいたします。 Sub 集計コピー操作() Dim 集 As Workbook, 開 As Workbook Dim 原 As Worksheet, コピー As Worksheet Dim パス As String, フォルダ As String Dim 日付 As String Dim 紙 As Integer Dim 終 As Integer Dim 数 As Long '書込み行 '日付取得 日付 = Format(Date, "yyyymmdd") '新規シート追加 'シート名チェック Set 集 = ThisWorkbook For Each 原 In 集.Worksheets If 原.Name = 日付 Then 原.Activate Exit For End If Next 原 'シート作成 If 原 Is Nothing Then 'シート名が存在しない場合は作成 Sheets("原本").Copy Before:=Sheets(1) Set 原 = ActiveSheet 原.Name = 日付 Else End If 'Application.ScreenUpdating = False '画面ちらつき防止 'ファイル名設定 Set 集 = ThisWorkbook 'このbookをまとめとする。 パス = ThisWorkbook.Path 'このbookのパスを取得 フォルダ = Dir(パス & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until フォルダ = Empty '全て検索 If フォルダ <> 集.Name Then 'book名がこのbookの名前でなければ 'コピーブックの設定 Set 開 = Workbooks.Open(パス & "\" & フォルダ) '開ファイルとする。 紙 = Worksheets.Count 'シートカウント For 終 = 1 To 紙 数 = 数 + 1 'シートループ処理 For Each コピー In 開.Worksheets With WorksheetFunction 原.Cells(数, "A").Value = コピー.Range("B1").Value 原.Cells(数, "B").Value = コピー.Range("B2").Value 原.Cells(数, "C").Value = コピー.Range("B3").Value 原.Cells(数, "G").Value = コピー.Range("B4").Value 原.Cells(数, "H").Value = コピー.Range("B5").Value 原.Cells(数, "J").Value = コピー.Range("B6").Value 原.Cells(数, "D").Value = コピー.Range("J22").Value 原.Cells(数, "E").Value = コピー.Range("J23").Value 原.Cells(数, "F").Value = コピー.Range("J24").Value End With Next Next 'ブッククローズ処理 開.Close (False) '保存せずに閉じる End If フォルダ = Dir 'フォルダ内の次のbookを検索 Loop Application.ScreenUpdating = True '画面ちらつき防止を解除 MsgBox 紙 & "件のファイルをコピーしました。" End Sub

  • VBAのハイパーリンクにつきまして

    以前に質問をさせていただき、こちらでベストアンサーを決定した後に急きょ変更があったところがあり、わからなくなってしまいこちらに戻ってきた次第です。 http://okwave.jp/qa/q8743521.html にて質問をさせていただきました内容について、以下のVBAで解決できております。 しかし、抽出したファイル名にハイパーリンクが欲しいという要望を受けてしまいました。 ハイパーリンクのVBAについていろいろ調べましたが、この記述方法に追加して実行する方法が全く分かりませんでした。 お分かりになる方がいましたら、この内容にハイパーリンクをつける方法をお教えいただけますでしょうか。よろしくお願いいたします。 Sub Macro1() Dim i As Long Dim myPath As String, Flnm As String ReDim Flnmfp(0) As String Dim WS1 As worksheet Set WS1=ThisWorkbook.sheets("sheet1") myPath="望みのフォルダパスを入力" Call fpFileName(myPath, Flnmfp ) 'フォルダ内のファイル名取得 If Ubound(Flnmfp)=0 Then 'フォルダにファイルが無ければ終了 Exit Sub End if For i =1 to Ubound(Flnmfp) Workbooks.open filename := Flnmfp(i) Flnm=Dir(Flnmfp(i)) With Workbooks(Flnm).sheets("sheet1") WS1.Cells(2, i).value=.Range("G5").value WS1.Cells(3, i).value=.Range("G6").value WS1.Cells(4, i).value=.Range("K7").value WS1.Cells(5, i).value=CStr(.Range("G9").value) & CStr(.Range("N9").value) & CStr(.Range("P9").value) '同じ要領で望みのセルを記入する WS1.Cells(8, i).value=Flnm End with Workbooks(Flnm).close Savechanges:=False Next i End Sub Sub fpFileName(ByVal myPath As String, ByRef Flnmfp() As String) 'サブフォルダも含め全部のxlsファイル名をフルパスで取得する   Dim cnt As Long, buf As String, f As Object   buf = Dir(myPath & "\*.xls")   Do While buf <> ""     cnt = Ubound(Flnmfp) + 1 ReDim Preserve Flnmfp(cnt)     Flnmfp(cnt)= myPath & "\" & buf     buf = Dir()   Loop   With CreateObject("Scripting.FileSystemObject")     For Each f In .GetFolder(myPath).SubFolders       Call fpFileName(f.Path, Flnmfp)     Next f   End With End Sub