Excel VBAで開いていないファイルの値を参照する方法
- Excel VBAを使用して、フォルダ内のExcelファイルの一覧と各ファイルのF1セルに入力されている値を取得し、Mainシートに表示する方法についてご質問です。
- パスワードがかかっているファイルがある場合、パスワード入力のダイアログが表示されてしまう問題が発生しています。
- パスワードが掛かっている場合でも、Mainシートの特定のセルに事前にパスワードを入力しておき、その値を参照することでダイアログを表示させずに値を取得する方法はありますか？
- ベストアンサー
Excel VBA 開いていないファイルの値参照について
フォルダ内にあるExcelファイル名の一覧と各ファイルのF1セルに 入力されている値を、Mainシートに表示するため以下の内容のマクロを 作成しました。 値の参照はうまく出来たのですが、パスワードがかかっているファイルが あった場合、パスワード入力のダイアログが表示されてしまいます。 パスワードは全て同じで決まっているので、 例えばMainシートの何処かのセルにパスワードを入力しておき、 パスワードが掛かっている場合は、その値を参照してダイアログを表示させずに、 値の参照をするというような事はできないものでしょうか？ ChangeFileAccessなどを使ってもみましたが、出来ませんでした。 どなたか良い方法をご存知の方がいましたら教えて下さい。 Option Explicit Dim Uketuke_FP As Variant Dim Uketuke_FN As String Private Sub CommandButton1_Click() Dim I As Integer Dim wsUke As String Uketuke_FP = Select_Fol() I = 6 Uketuke_FN = Dir(Uketuke_FP & "＊.xls") wsUke = "受付票" Do While Uketuke_FN <> "" Range("AA1") = "='" & Uketuke_FP & "[" & Uketuke_FN & "]" & wsUke & "'!F1" Cells(I, 6) = Range("AA1").Value Cells(I, 7) = Uketuke_FN Uketuke_FN = Dir() I = I + 1 Range("AA1").ClearContents Loop End Sub Option Explicit Function Select_Fol() With Application.Filedialog(msoFileDialogFolderPicker) If .Show = True Then Select_Fol = .SelectedItems(1) End If If Select_Fol = "" Then End If Right(Select_Fol, 1) <> "\" Then Select_Fol = Select_Fol & "\" End If End With End Function
- ukemochi
- お礼率90% (9/10)
- オフィス系ソフト
- 回答数1
- ありがとう数2
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
リンク先の様な方法もあります。 SendKeysは不安定らしく、評判が良くないですが。 http://qa.asahi.com/qa3574420.html
関連するQ&A
- エクセルVBAで教えてください。
サイトで既出のコードを若干変えて下のようにして使っています。 下のコードでダイアログを呼び出し、フォルダを指定して、ハイパーリンクでそのフォルダを開くようになっているのですが、ファイルそのものを指定して、ハイパーリンクでファイルを開くようにするにはどうすればいいでしょうか。下のコードの一部を変えれば可能であれば、下のコードを踏襲して教えていただければ有難いです。 よろしくお願いします。 Sub hyperlink() Dim Fol As Object Dim fp As String Set Fol = CreateObject("Shell.Application"). _ BrowseForFolder(0, "フルパスを取得します。ハイパーリンクにしたいフォルダを指定してください。", 0) If Not Fol Is Nothing Then Range("IV1").Value = Fol.Items.Item.Path End If Application.ScreenUpdating = False Range("IV1").Copy Range("A65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues fp = Range("A65536").End(xlUp).Value ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fp, TextToDisplay:=fp Application.CutCopyMode = False Range("IV1").ClearContents Application.ScreenUpdating = True MsgBox "ハイパーリンクを設定しました。" End Sub
- ベストアンサー
- オフィス系ソフト
- VBAにてアクティブでは無いシートの値が参照されてしまいます。
こんばんは、以前二回程質問させていただいた物です。 過去のアドバイスから少しずつ疑問をつぶしていった所再び問題が発生してしまいました。 同じプログラムを何度も載せるのは大変恐縮ですが、どうしても解決出来ない為(私の努力不足は重々承知です)皆様の力を貸して頂きたいと思います。 以下のようなループの際、途中にMsgBox(strFILENAME)を入れたり、Active.sheetでウオッチ式で見ても参照してほしいシート名を表示するにも関わらず、計算結果を書き込むシートのセルを参照してしまいます。 なぜ、WS1のセルの値を参照してしまうのかわからず困っています。 確実にMsgBox(strFILENAME)で表示されるファイル名のシートのセルを参照する方法を教えて頂きたく、よろしくお願いいたします。(Workbook.Worksheet.のように明示する方法を教えていただいたのですがエラーが発生してしまいうまく使いこなすことが出来ませんでした) どうか、宜しくお願いいたします。 Option Explicit Sub syoutotumen() Dim i As Long Dim j As Long Dim k As Long Dim kyori As Long Dim n As Integer n = 1 i = 1 j = 1 k = 1 Const cnsYEN = "\" Dim swESC As Boolean Dim ws1 As Worksheet Dim xlAPP As Application Dim objWBK As Workbook Dim strPATHNAME As String Dim strFILENAME As String strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理２\" If strPATHNAME = "" Then Exit Sub strFILENAME = Dir(strPATHNAME & "demo******", vbNormal) If strFILENAME = "" Then MsgBox "このフォルダにはExcelワークブックは存在しません" Exit Sub End If Set xlAPP = Application With xlAPP .ScreenUpdating = False .EnableEvents = False .EnableCancelKey = xlErrorHandler .Cursor = xlWait End With Set ws1 = Worksheets("sheet1") Range("A1") = "0" Range("A2") = "1" Range("A1:A2").Select Selection.AutoFill Destination:=Range("A1:A1022") Do While strFILENAME <> "" DoEvents If swESC = True Then If MsgBox("ESCが押されました。ここで終了しますか？", vbInformation + vbYesNo) = vbYes Then GoTo Button1_Click_Exit Else swESC = False End If End If xlAPP.StatusBar = strFILENAME & "処理中・・・" Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True) Do If Cells(i, 2) = 0 Then Exit Do i = i + 1 Loop Do If Cells(j, 3) = 0 Then Exit Do j = j + 1 Loop Do If Cells(k, 4) = 0 Then Exit Do k = k + 1 Loop kyori = (i + j + k - 21) / 3 ws1.Cells(n, 2) = kyori n = n + 1 i = 1 j = 1 k = 1 objWBK.Close savechanges:=False strFILENAME = Dir Loop GoTo Button1_Click_Exit Button1_Click_ESC: If Err.Number = 18 Then swESC = True Resume ElseIf Err.Number = 1004 Then Resume Next Else MsgBox Err.Description End If Button1_Click_Exit: With xlAPP .StatusBar = False .ScreenUpdating = True .EnableEvents = True .EnableCancelKey = xlInterrupt .Cursur = xlDefault Set objWBK = Nothing Set xlAPP = Nothing End With End Sub
- ベストアンサー
- オフィス系ソフト
- VBAで複数の行のナンバーを取得し、その行の列の値を参照して値を入れる
下記のことをしたいのですが、調べてもわかりません。 どなたか教えてください。 よろしくお願いします。 内容： エクセルシートのA列の値が11である行ナンバーを取得（複数ある可能性があります）する。 その行のE列（5列目）の値と他のテーブルの値を参照して所定の値をA列の値が11である行のE列（5列目）に返す。 以下のVBAを書いてみましたがうまくいきません。 ----------------------------------------------------------------- Dim ROWCOUNT As Integer Dim row_array() As Variant Dim i As Integer '全行数を取得 ROWCOUNT=Worksheets("sheet1").Range("A1",Range("A65536").End(xlUp)).Count For i = 1 To ROWCOUNT If Cells(i, 1).Value = 11 Then Cells(i,1).Offset(0,5).Value=WorksheetFunction.VLookup(Cells(i, 1).Offset(0, 5).Value, Worksheets("sheet2").Range("A1:H1786"), 3, False) End If Next I
- ベストアンサー
- その他（プログラミング・開発）
- エクセル2007 参照セルの値が認識されない
エクセル2007の環境で下記マクロを実行すると、 アクティブシートのセルA1に数字が入っている場合、Sheet1のセルA1に値を転記しても そのセルA1の値をVLOOKUP関数で参照できません。 マクロに問題があるためなのか何処に問題があるのか分からないので教えてください。 宜しくお願いいたします。 【sheet】は アクティブシートの3行目から1000行目までのA列のセルをクリックしたらセルA1に値を表示 その後、下記【モジュール】を使用し、 アクティブシートのセルA1が空白の場合、 A列の数値をSheet1のセルA1に転記し、アクティブシートのA列の数値が空白になるまで循環する。 Sheet1のセルA1の値をVLOOKUP関数で参照した内容を表示、印刷します。 ----------------------------------------------------------------- '【sheet】 Private Sub Worksheet_SelectionChange(ByVal Target As Range) With Target If .Count > 1 + IsEmpty(.Value) Then Exit Sub If Application.Intersect(.Cells, Range("A3:A1000")) Is Nothing Then Exit Sub ActiveSheet.Cells(1, 1).Value = .Value End With End Sub ----------------------------------------------------------------- '【モジュール】 Sub TEST() Dim myBtn As Integer Dim myMsg As String, myTitle As String Dim WS1 As Worksheet, WS2 As Worksheet Dim i As Long myMsg = "●●●" myTitle = "確 認" myBtn = MsgBox(myMsg, vbYesNo + vbExclamation, myTitle) If myBtn = vbYes Then Set WS1 = ActiveSheet Set WS2 = Sheet1 If WS1.Cells(1, 1).Value = "" Then With WS1 For i = 3 To 65536 If .Cells(i, 1).Value = "" Then Exit For WS2.Cells(1, 1).Value = .Cells(i, 1).Value WS2.Cells(1, 2).Value = ActiveSheet.Name 'WS2.PrintOut Copies:=1 Next i End With ElseIf WS1.Cells(1, 1).Value >= 1 Then WS2.Cells(1, 1).Value = WS1.Cells(1, 1).Value WS2.Cells(1, 2).Value = WS1.Name 'WS2.PrintOut Copies:=1 Else End If End If End Sub -----------------------------------------------------------------
- ベストアンサー
- その他MS Office製品
- EXCEL VBA におけるブック終了後の値の保存方法について
ＥＸＣＥＬ ＶＢＡについて質問があります。もしかしたら初歩的なことかもしれませんがよろしくお願いいたします。 まず、 Sub Test() Dim i As String i = InputBox("好きな果物を入力してください") Sheets("Sheet1").Range("A1").Value = i End Sub を実行し、ブックを保存して終了する。 ブックを開く Private Sub Workbook_Open() Dim k As String k = Sheets("Sheet1").Range("A1").Value If k = "みかん" Then MsgBox ("a") Else: MsgBox ("b") End If End Sub この処理を Sheets("Sheet1").Range("A1").Value = i というシート上のセルに値を保存するという方法を取らずに iの値をブック終了後もプロシージャ内に持っておくというのは可能なのでしょうか。 Publicで宣言してもブックを一度閉じると やっぱりiの値は保存されませんでした。 どうぞよろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBA
よろしくお願いいたします。 エクセルのVBAですが、下記のコードを実行すると処理が遅いです。処理が早くなるコード教えてください。 よろしくお願いいたします。 Sub Macro3() Dim aa As Variant Dim i As Variant Application.ScreenUpdating = False Range("A14:i46").Select aa = ActiveSheet.Name ActiveWorkbook.Worksheets(aa).Sort.SortFields.Clear ActiveWorkbook.Worksheets(aa).Sort.SortFields.Add Key:=Range("B15:B46"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets(aa).Sort.SortFields.Add Key:=Range("C15:C46"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets(aa).Sort .SetRange Range("A14:i46") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With For i = 0 To 31 Cells(15 + i, 7).Select If Selection.Value = 0 Then Selection.EntireRow.Hidden = True End If Next i Range("A1").Select Application.ScreenUpdating = True End Sub
- ベストアンサー
- オフィス系ソフト
- VBA エクセル 列の並び替え
左から右にA、B、Cと値が入っています。 ABC以外の文字が列に入っていたら、削除するというマクロを組みましたが、範囲を設定するところでエラーが出てしまいました。 なぜでしょうか？ 教えて下さい。 Sub arrange() Dim rg As Range Dim i As Long i = 1 Do rg = Cells(i, 1) If rg <> "A" And rg <> "B" And rg <> "C" Then Range(i & ":" & i).Delete End If i = i + 1 Loop Until (i & "1") = "" End Sub
- ベストアンサー
- オフィス系ソフト
- VBAのファイル参照について
セルの変更時、列によって行の内容を変更するプログラムを組んだのですが、 エラーが起きてうまくいきません。 使用しているExcelは2007です。 ファイルを参照するあたりが全然わかってないのでそのあたりがあやしいです。 実行時エラー '91': オブジェクト変数または With ブロック変数が設定されていません。 → hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '係数表をコピー ↓デバッグ押すと 実行時エラー '-2147417848 (80010108)': 'Value' メソッドは失敗しました: 'Range'オブジェクト → Call all_feeCulc_change2(target.Parent.Name, target.row) 番号をメモし忘れました。91かこれが表示されます。どちらが出るかわかりません。 'Range' メソッドは失敗しました:'_Worksheet' オブジェクト →endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得 何回かリトライして開いたり閉じたりを繰り返したら↓のようなダイアログも出ました。 マクロでスタック領域が不足しています また、ダイアログで終了を押したらセルを正しく選択できなくなりました。 デバッグを押したら、停止ボタンを押すと応答なしになった後、Excelが終了し再起動しました。 そして、どちらを選択した場合でも、メニューや閉じるボタンを押してもExcelが終了できず、 タスクマネージャからプロセスを終了させるしかなかったです。 その時CPU使用率が50%を超えてたりと異常事態になっております。 ###標準モジュール### Sub all_feeCulc_change2(ByVal sheetName As String, ByVal row As Integer) If sheetName <> "" Then Dim customer As String customer = Worksheets(sheetName).Cells(row, 3) On Error Resume Next Dim book1 As Workbook '別ファイルのオープン（触らない） Workbooks.Open Filename:="hogehoge.xlsm" '別ファイルのオープン（触らない） Set book1 = Workbooks("hogehoge.xlsm") '別ファイルのオープン（触らない） On Error GoTo 0 Dim endrow As Integer '最終行番号 endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得 Dim hoge As Variant hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '早見表から係数表をコピー With Worksheets(sheetName) ... ###ThisWorkbook### Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range) If target.Count = 1 Then Dim column As Integer Dim row As Integer column = target.column row = target.row If row >= 3 Then If ((column - 3) Mod 5) = 2 And column > 3 Then '更新セルがメーターだったら Call usageCulc_change(target.Parent.Name, target.column, target.row) Call all_feeCulc_change(target.Parent.Name, target.column - 1, target.row) Call chenge_tax_change(target.Parent.Name, target.column + 1, target.row) ElseIf column = 3 Then target.Value = format(target.Value, "000") '誤入力防止 Call all_feeCulc_change2(target.Parent.Name, target.row) Call chenge_tax_change2(target.Parent.Name, target.row) End If End If End If End Sub Private Sub Workbook_Open() '*****すべてのシート名を取得*****' Dim ws As Worksheet Dim sheetName() As String ReDim sheetName(3) Dim cnt As Integer cnt = 0 For Each ws In Worksheets If cnt > 3 And (cnt Mod 4) = 0 Then ReDim Preserve sheetName(UBound(sheetName) + 4) End If sheetName(cnt) = ws.Name cnt = cnt + 1 Next '*****取得終了*****' Dim endrow As Integer Dim line As Variant For Each line In sheetName If line <> "000" And line <> "" Then With Worksheets(line) endrow = .Cells(Rows.Count, 3).End(xlUp).row Dim i As Integer Dim j As Integer For i = 0 To endrow For j = 0 To 11 .Cells(3 + i, 4 + j * 5).NumberFormatLocal = "0.0" .Cells(3 + i, 5 + j * 5).NumberFormatLocal = "0.0" .Cells(3 + i, 6 + j * 5).NumberFormatLocal = "#,##0" .Cells(3 + i, 7 + j * 5).NumberFormatLocal = "#,##0" .Cells(3 + i, 8 + j * 5).NumberFormatLocal = "#,##0" Next j Next i End With End If Next End Sub
- ベストアンサー
- Visual Basic
- エクセル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 ご教示よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- excel vbaについてです
VBA初心者で、暇な時にいろいろためしています。 以下のマクロを組んだのですが、エラーがでてうまくいきません。 どこがいけないのかご指摘願います。 Sub ather() Dim A As Range Dim B As Range Dim i As Integer With ThisWorkbook.Worksheets("Sheet1") For i = 1 To 30 Set A = Cells(i, 1) Set B = Cells(1, i) If Not .Range(A).Interior.ColorIndex = vbYellow Then GoTo port10 If Not .Range(B).Interior.ColorIndex = vbRed Then GoTo port10 .Range(B).Offset(, 1).Value = "○" port10: Next i End With End Sub イメージとしてはセルの塗りつぶしが黄色で、かつ右隣のセルの塗りつぶしが赤の時に、 赤色セルの右隣のセルに○を表示させようとしているのですが。。。 こうしたらいいんじゃない？といったアドバイスもお願いします(-人-)
- ベストアンサー
- その他MS Office製品
お礼
早々の回答有難うございました。 リンク先の内容を読み、SendKeysにしようかと思いましたが 不安定で評判が良くないとの事でしたので、 最終的にはWorkbook.Openで対応することにしました。