マクロでリレーショナルデーターベースを操作する方法について教えてください

前へ 次へ
このQ&Aのポイント
  • 私はマクロについて理解が不足しております。リレーショナルデーターベースを操作するマクロを作成したいのですが、ExcelファイルのOPENとCLOSEのみ実行できてしまいます。具体的には、別のExcelファイル「生産準備」を参照し、条件に合致するデータをローカルのExcelファイルに格納したいです。Windows XPとOffice 2000を使用しています。また、共有サーバー上にある「生産準備」というファイルを、ローカルのExcelファイルで参照する方法も教えてください。
  • リレーショナルデーターベースをマクロで操作したいのですが、ExcelファイルのOPENとCLOSEのみができてしまいます。具体的には、共有サーバー上にある「生産準備」というファイルを、ローカルのExcelファイルで参照して条件に合致するデータを取得し、他のセルに格納したいです。Windows XPとOffice 2000を使用しています。マクロについて詳しい方、ご教授願い申し上げます。
  • Excelのマクロでリレーショナルデーターベースを操作したいですが、ExcelファイルのOPENとCLOSEのみができてしまいます。具体的には、共有サーバー上の「生産準備」というファイルをローカルのExcelファイルで参照して、条件に一致するデータを取得し、他のセルに格納したいです。Windows XPとOffice 2000を使用しています。詳しい方にアドバイスをいただきたいです。
回答を見る
  • ベストアンサー

MACROでリレーショナルデーターベース

マクロが全然理解できていない者です。ですのでバカでもチョンでもわかるようにご教授願いできないでしょうか？ 下記のようなマクロを作成したいのですが別のEXCELファイル「生産準備」をOPENとCLOSEまでしか どうしてもできません。 WINDOWはXPでOFFICEは2000にて全部２つのEXCELのファイルがあります。 １つ共有サーバー上にあり１つローカルドライブにある環境です。 共有サーバー上の\\Seizo-kyoyu\share\共有\製造部\文書という場所にあるフォルダに格納されている生産準備というファイル（シート名は「DATA」）をローカルドライブにあるEXCELファイルにて参照するVBAをご教授願います。 共有ファイル（生産準備）のB列（1行目は題名で2行目から1000行まで一覧となっています。）を参照してローカルドライブの$E$9のセルと同じ文字列があれば　 その同じ行のD列とE列にある文字列をローカルドライブのファイルの それぞれ$C$337と$C$336のセルに格納するようにしたいのです。 もし同じ文字列がなければ「該当データなし」と表示して欲しい。 Private Sub Workbook_Open() Dim buf As String, wb As Workbook Const Target As String = "\\Seizo-kyoyu\share\共有\製造部￥文書\生産準備.xls" 'ファイルの存在チェック buf = Dir(Target) If buf = "" Then MsgBox Target & vbCrLf & "は存在しません", vbExclamation Exit Sub End If '同名ブックのチェック For Each wb In Workbooks If wb.Name = buf Then MsgBox buf & vbCrLf & "はすでに開いています ", vbExclamation Exit Sub End If Next wb 'ここでブックを開く Workbooks.Open Target, ReadOnly:=True 'ここで検索する 'ここでブックを閉じる Workbooks("生産準備.xls").Close savechanges:=False End Sub お手数をお掛けしますがなにとぞ宜しくお願い致します。

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

  • ベストアンサー
  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.1

手順： 今のマクロを消去する ThisWorkbookシートに下記を記載する private sub Workbook_Open() 　Dim buf As String, wb As Workbook 　Const Target As String = "\\Seizo-kyoyu\share\共有\製造部￥文書\生産準備.xls"'ファイルの存在チェック 　buf = Dir(Target) 　If buf = "" Then 　　MsgBox Target & vbCrLf & "は存在しません", vbExclamation 　　Exit Sub 　End If 　worksheets("Sheet1").select　’結果を記入するシート名を正しく指定 　range("C337").formula = "=VLOOKUP(E9,'\\Seizo-kyoyu\share\共有\製造部\文書\[生産準備.xls]DATA'!$B$2:$E$1000,3,FALSE)" 　if iserror(range("C337")) then 　　range("C336:C337") = "該当データなし" 　else 　　range("C336").formula = "=VLOOKUP(E9,'\\Seizo-kyoyu\share\共有\製造部\文書\[生産準備.xls]DATA'!$B$2:$E$1000,4,FALSE)" 　　range("C336:C337").value = range("C336:C337").value 　end if end sub ブックを保存し、閉じて開きなおす。

CVN-77
質問者

お礼

返信ありがとうございました。 無事できました。 コード解読して勉強します。 また何かありましたら宜しくお願い致します。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. Excel（エクセル）

関連するQ&A

  • VBA（ExecuteExcel4Macro）を用いた検索ツール

    VBA（ExecuteExcel4Macro）を用いた検索ツール はじめまして。 当方Excel2007、winXPでの環境下でVBAを用いた検索ツールを作成しています。 検索対象のxlsファイルには1行目に郵便番号、氏名、住所の項目タイトル、2行目以降にデータが入力されています。 【現在の仕様】 検索対象のxlsファイルを選択→検索したい氏名（3つまで）を入力すると氏名列を順に検索し、該当した氏名のみをシートへ出力 【作りたい仕様】 検索対象のxlsファイルを選択→検索したい氏名（3つまで）を入力すると氏名列を順に検索し、該当した氏名の入力された行をシートへ出力 現在のソースは下記になりますが、どのように書き変えればいいのかが分からず困っています。 教えていただけたらと思います。よろしくお願いいたします。 ------------------------- （略） ''対象ブックを選択します OpenFileName = Application.GetOpenFilename("Microsoft Excel ブック,*.xls") If OpenFileName = "False" Then Exit Sub OpenFileName = Replace(OpenFileName, Dir(OpenFileName), "[" & Dir(OpenFileName) & "]") SheetName = InputBox("読み込むワークシート名を入力してください。") If SheetName = "" Then Exit Sub Target = "'" & OpenFileName & SheetName & "'!" On Error Resume Next buf = ExecuteExcel4Macro(Target & "R1C1") If Err <> 0 Then MsgBox "ワークシート [ " & SheetName & " ] を読めませんでした。", vbExclamation Exit Sub End If On Error GoTo 0 key1 = InputBox("検索したい氏名1を入力してください。") If key1 = "" Then Exit Sub End If key2 = InputBox("検索したい氏名2を入力してください。") If key2 = "" Then Else key3 = InputBox("検索したい氏名3を入力してください。") End If For i = 1 To 256 If ExecuteExcel4Macro(Target & "R1C" & i) = "名前" Then TargetCol = i Exit For End If Next i If TargetCol = 0 Then MsgBox "[ 名前 ]フィールドが見つかりません。", vbExclamation Exit Sub End If Dim clm As Integer For i = 2 To 10000 buf = ExecuteExcel4Macro(Target & "R" & i & "C" & Target If buf = "0" Then Exit For If buf = key1 Then Sheet3.Cells(w, 3) = buf w = w + 1 ReDim Preserve GetNames(i - 1) GetNames(i - 1) = buf ElseIf buf = key2 Then Sheet3.Cells(w, 3) = buf w = w + 1 ReDim Preserve GetNames(i - 1) GetNames(i - 1) = buf （略） -----------------

  • マクロ　エクセル２００３

    いつも回答して頂き感謝しています。 原紙のブックを開き、別の名前を付けて保存するマクロを考えています。 原紙のブックを開くマクロはネットから探して、少し修正して出来あがったのですが、 この開いた原紙のブックに別の名前を付けて保存するマクロで困っています。 ただ単に名前を付けるだけだったら問題無いのですが、 その名前が既に保存されていないか確認した後、保存としたいのです。 ブックを開く記述を少し引用して出来ないかやってみたのですが、 Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile で、定数式が必要です。と表示されエラーが発生してしまいます。 どのように変更したら上手くいくのでしょうか？宜しくお願い致します。 Sub Sample() Dim buf1 As String Dim buf2 As String Dim NewFile As String Dim ws1 As Worksheet Dim wb As Workbook Set ws1 = ThisWorkbook.Worksheets("作成") NewFile = "借入貸出" & ws1.Range("C4").Value & "." & ws1.Range("D4").Value Const Target1 As String = "C:\Users\Owner\Documents\借入貸出原紙.xlsx" Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile　& ".xlsx" buf1 = Dir(Target1) If buf1 = "" Then MsgBox Target1 & vbCrLf & "は存在しません", vbExclamation Exit Sub End If For Each wb In Workbooks If wb.Name = buf1 Then Application.DisplayAlerts = False Workbooks("借入貸出原紙.xlsx").Close Application.DisplayAlerts = True End If Next wb Workbooks.Open Target1 buf2 = Dir(Target2) If buf2 = "" Then End If End Sub

  • ExecuteExcel4Macroを使ったレコードの読み込み方法につ

    ExecuteExcel4Macroを使ったレコードの読み込み方法について 下記サンプルは、ファイルを指定して、指定したファイルの中にあるシートを選択し、その中にあるデータを読込むものになっています。 読込ませるファイルのsheet1には、『 ID，顧客番号，氏名，住所，電話番号 』 が入っています。 下記サンプルでは、顧客番号フィールドのデータは読込めるのですが、該当するレコード全体を読込むにはどう組み立てればいいかよくわかりません。 すみませんが、どなたかご教授いただけませんでしょうか。よろしくお願いいたします。 Public Sub testes() ' 変数の指定 Dim OpenFileName, SheetName, Target, buf As String Dim i, TargetCol As Long, GetNames() ' 対象ブックの選択 OpenFileName = Application.GetOpenFilename("Microsoft Excel ブック,*.xls") If OpenFileName = "False" Then Exit Sub ' ファイル名に[]を付ける OpenFileName = Replace(OpenFileName, Dir(OpenFileName), "[" & Dir(OpenFileName) & "]") ' 対象ワークシート名の指定と取得 SheetName = InputBox("対象ワークシート名を入力します") If SheetName = "" Then Exit Sub Target = "'" & OpenFileName & SheetName & "'!" ' ワークシートの正誤チェック On Error Resume Next buf = ExecuteExcel4Macro(Target & "R1C1") If Err <> 0 Then MsgBox "ワークシート [ " & SheetName & " ] を読めませんので終了します。", vbExclamation Exit Sub End If On Error GoTo 0 ' [顧客番号]フィールドを探す For i = 1 To 256 If ExecuteExcel4Macro(Target & "R1C" & i) = "顧客番号" Then TargetCol = i Exit For End If Next i If TargetCol = 0 Then MsgBox "[顧客番号]フィールドが確認できません。", vbExclamation Exit Sub End If ' データの読み込み For i = 1 To 10000 buf = ExecuteExcel4Macro(Target & "R" & i) If buf = "0" Then Exit For ' シートに出力する Worksheets("sheet3").Activate ActiveSheet.Cells(i, 1) = buf Next i End Sub

  • excelのファイルとセル値を書き出したい

    excel2003を利用しています。 とあるフォルダにある excelファイル名(自分自身のファイルを除く） を全て書き出して、 且つ A１セルの値をB列に書き出すことを、やろうとvbaを作ってみましたが。 最後のファイルのA1セルを書きだすところで、エラーになっていまい そこだけ空白になってしまいます。※写真参照 記述は以下の通りです。どのように修正すればよいか 教えていただけないでしょうか？ また他にもっと優れた記述があれば、そちらも教えて欲しいです。 よろしくお願いします。 Sub test() Dim buf As String, cnt As Long Dim Path As String Path = ThisWorkbook.Path & "\" buf = Dir(Path & "*.xls") cnt = 2 Do While buf <> "" If buf <> ThisWorkbook.Name Then cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Workbooks.Open Filename:=Path & "\" & buf MsgBox Workbooks(buf).Worksheets(1).Range("A1").Value Cells(cnt, 2) = Workbooks(buf).Worksheets(1).Range("A1").Value Workbooks(buf).Close End If Loop End Sub

  • macroについて教えてください

    こんにちは。以前こちらでPrivate SubについてMacroを教えていただきました。（あの後ログインパスワード等が不明になりお礼も出来ませんでしたが。。。回答頂いた方すみませんでした。） 下記がそのMacroですが、今回また少し変えることになり どのように変えていいのか分かりません。 前回は1～5はグレー、6～10は茶色・・・という形にしたのですが 今回は進捗率での管理をしたく、80％以下は白、80～90％は赤、90～100％は青としたいと思っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim iColors As Variant Dim rw As Long Dim CellCnt As Integer Dim col As Integer Dim col2 As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim c As Variant Dim ar() As Variant Dim Sh1 As Worksheet Set Sh1 = Worksheets("小児科Dr") col = Target.Cells(1).Column '制限された列 If Not (col = 4 Or col = 8 Or col = 12 Or col = 16) Then Exit Sub iColors = Array(16, 16, 16, 16, 16, 53, 53, 53, 53, 53, 54, 54, 54, 54, 54) CellCnt = Target.Count ReDim ar(CellCnt - 1) For Each c In Target If c.Value <> "" Then If IsNumeric(c.Value) Then i = c.Value If i >= 11 Then i = 10 End If If i > 0 And i < 11 Then j = iColors(i - 1) Else j = 2 End If ar(k) = j k = k + 1 End If End If Next c rw = Target.Row Select Case col Case 4: col2 = 2 Case 8: col2 = 8 Case 12: col2 = 14 Case 16: col2 = 20 'Sh1.Cells(rw + 2, 13).Resize(Int(Target.Count / 3), 3).Interior.ColorIndex = j End Select InsideColors Sh1, rw, col2, CellCnt, ar() Set Sh1 = Nothing End Sub Private Sub InsideColors(sh As Worksheet, _ rw As Long, _ col As Integer, _ cnt As Integer, _ ar As Variant) 'sh[シート],rw[行], col[列],cnt[セル個数],iColor[色指数] Dim i As Integer Dim j As Integer Dim n As Integer Dim k As Integer If cnt Mod 5 > 0 Then '範囲行数 i = (cnt + 5 - (cnt Mod 5)) / 5 Else i = cnt / 5 End If rw = Int((rw - 1) / 5) + 1 '行再設定 j = ((rw - 1) Mod 5) + 1 '列設定 For n = j To cnt sh.Cells(rw + 2, col).Resize(i, 5).Cells(n).Interior.ColorIndex = ar(k) k = k + 1 Next n End Sub 毎回他の人を頼ってしまい、申し訳ないのですがお願いします。 また、前回分からなかったので1～5を指定するときに5回同じカラー番号を書いたのですがこちらも良かったら手直し方法を教えていただければ助かります。 宜しくお願いします。

  • 可視セルだけを選択対象にしたい

    I列の6行目～最終行までをキーにして、別ファイルにセルの値をコピペするコードを作りました Sub test() Dim wb(1 To 2) As Workbook Dim II As Long, pt As String With Application Set wb(1) = .Workbooks("A.xls") Set wb(2) = .Workbooks("B.xls") pt = wb(2).Path If Right(pt, 1) <> .PathSeparator Then pt = pt &.PathSeparator End With II = 6 Do With wb(1).Worksheets("Sheet1").Cells(II, "I") If .Value = "" Then Exit Do wb(2).Worksheets("Sheet1").Range("A1").Value = .Value wb(2).Worksheets("Sheet1").Range("A2").Value =.Offset(0, 1).Value wb(2).SaveAs pt & .Value & ".xls" End With II = II + 1 Loop wb(2).Close Erase wb End Sub 始まりはI列の6行目からなのですが、フィルタをかけるため行番号が飛び飛びになり、上記コードでは思った答えが出ません フィルタをかけた後の可視セルの状態で上記コードを動かしたいのですが、 うまく修正ができません・・・ どなたかご教授いただけますでしょうか よろしくお願い致します

  • VBAで新しい日付順にファイルを検索するには？

    ExcelのVBA初心者です。 ファイルを新しい日付のものから順番に検索したいのですが、幾ら探しても分かりませんでした。どなたか教えていただけないでしょうか？ やりたいことは、あるフォルダ内に毎日5～6個のファイルが保存されていくのですが、その中の決められたセルに指定した文字列が含まれているもの3つ場合分けしてファイルを出力したいのです。 例えば、 　ファイル名　　　セルE1の内容　　　　日付 　123.xls　　　　　”111111A”　　　　6/29 15:39:40 　456.xls　　　　　”111111N”　　　　6/29 15:35:10 　789.xls　　　　　”222222V”　　　　6/29 15:20:43 　654.xls　　　　　”222222A”　　　　6/29 14:30:21 　321.xls　　　　　”111111V”　　　　6/29 14:10:33 　951.xls　　　　　”222222N”　　　　6/28 17:52:15 　753.xls　　　　　”333333A”　　　　6/28 17:30:50 とファイルがあり、セルE1に”111111”の文字列を含むファイルを検索し、 　末尾に”V”があるもの → f(1)=321.xls 　末尾に”N”があるもの → f(2)=456.xls 　末尾に”A”があるもの → f(3)=123.xls と出力したいのです。 分からないなりに、いろいろ調べて切り貼りしながら作ってみました。 これで一応うまくいったのですが、検索する文字列は、必ず上記例のように新しい日付の5～6ファイルの中にあり、検索対象のフォルダ内には1000個以上ファイルがあります。 上記プログラムだと読み込む順番が最後になってしまいますので、恐ろしく処理時間が掛かってしまいます。 Sub ファイル検索() Dim buf As String, cnt As Long Dim i As Integer Dim wb(3) Dim bk As String, lot As String, lt As String Dim Path As String Application.ScreenUpdating = False lt = Cells(1, 5) bk = ActiveWorkbook.Name Path = Cells(1, 5) buf = Dir(Path & "*.xls") i = 1 Do While wb(1) = "" Or wb(2) = "" Or wb(3) = "" cnt = cnt + 1 Workbooks.Open Path & buf Select Case Cells(2, 5) Case Is = lt & "V" wb(1) = buf Case Is = lt & "N" wb(2) = buf Case Is = lt & "A" wb(3) = buf End Select Application.DisplayAlerts = False Workbooks(buf).Close Application.DisplayAlerts = True buf = Dir() Loop For i = 1 To 3 Workbooks(bk).Sheets(1).Cells(i, 1) = "wb(" & i & ")" & "=" & wb(i) Next i Application.ScreenUpdating = True End Sub 日付の新しいファイルから読み込む良い方法はないでしょうか？ Excelのバージョンは、2003です。 出来れば、2003～2010で対応できる方法があれば、ベストです。 よろしくお願い致します。

  • ドライブが違ってもファイルが正常に開けるようする

    windows7 Excel2007を使って、みようみまねでマクロ作成の初心者です。 　現在　遠方の知人とEXCELブックのやり取りをしています。 　　フォルダの中にＡ・Ｂ・Ｃブックとマクロ記入用のＤブックが入っており 　　これをフォルダごと送っています。双方とも以下のマクロで開いています。 　　Sub Ｅァイルを開く() Dim wb As Workbook On Error Resume Next '開いて作業中の場合 Set wb = Workbooks("Ｅファイル.xls") On Error GoTo 0 If wb Is Nothing Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\Ｂフォルダ名\Ｅファイル.xls") End If End Sub 　　変更　私のマイドキュメントを外付けハードディスクのＨドライブに移動する。 　　　　　　　￥Ｈ￥マイドキュメント￥計算処理 　　　　　知人のマイドキュメントを外付けハードディスクのＦドライブに移動する。 　　　　　　　￥Ｆ￥マイドキュメント￥計算処理 　　　　　そしてやり取りは、マクロ記入のＤブックのみとする。 　　そしてやりたいことは、双方のパソコンでエラーなくファイルを開けるようにしたいのです。試行錯誤的にコード書きましたがうまくいきません。どうコードを書いたらよろしいでしょうか？ Sub 　Ｅファイルを開く() Dim wb As Workbook On Error Resume Next ChDrive "F" ''フォルダが存在するかどうか調べます Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.FolderExists("..\計算処理") Then '開いて作業中の場合。 Set wb = Workbooks("Ｅファイル.xls") On Error GoTo 0 If wb Is Nothing Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\Ｂフォルダ名\Ｅファイル.xls") End If Else ChDrive "Ｈ" ChDir "計算処理" '開いて作業中の場合。 Set wb = Workbooks("Ｅファイル.xls") On Error GoTo 0 If wb Is Nothing Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\Ｂフォルダ名\Ｅファイル.xls") End If Set FSO = Nothing End If End Sub

  • 【VBA】ExecuteExcel4Macro

    こんにちは、VBA初心者につき皆様のお知恵をお貸し下さい。 ExecuteExcel4Macroを使用し同一フォルダ内の複数ブックから値の取得を行う際に 特定のブックが開かれている（使用中）場合、それを判断する方法はありますでしょうか？ 当初は以下プログラムで判断していたのですが ファイル数が多い為１つ１つ開いてしまうととても処理時間が掛かるので 試行錯誤しながらExecuteExcel4Macroにたどり着きました。 ------------------------------------------------------------------------------------------- Set wb = Workbooks.Open(myFdr & "\" & fname) 　If ActiveWorkbook.ReadOnly Then 　　MsgBox "取得できませんでした" 　　ActiveWorkbook.Close 　　Exit Sub 　End If -------------------------------------------------------------------------------------------- 処理速度が早く出来るのであればExecuteExcel4Macroに拘りは無いので もし他にいい手段がありましたらご教授頂けると幸いです。 以上、宜しくお願い致します。

  • インプットボックスからファイルを開くようにしました。しかし、すでに開い

    インプットボックスからファイルを開くようにしました。しかし、すでに開いているか確認する項目がうまく作動しません。どのように記述するか教えて頂けませんでしょうか。 Sub Macro1() Dim wb As Workbook Dim psw As Boolean Dim fil As String fil = InputBox("ファイル名入力") For Each wb In Workbooks ’すでに開いているか確認。二重に開くのを防止 If wb.Name = "fil.xls" Then　’ここの部分がうまく作動してくれません。 psw = True Exit For End If Next wb If psw = False Then Workbooks.Open　Path & "C:￥" & fil End If End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する