Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

12903 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【7962】セルの値をファイル名に こじこじ 03/9/25(木) 14:25

【7975】Re:セルの値をファイル名に Jaka 03/9/25(木) 16:52

【7976】Re:セルの値をファイル名に Jaka 03/9/25(木) 16:59

【7984】Re:セルの値をファイル名に こじこじ 03/9/25(木) 19:40

【8000】Re:セルの値をファイル名に Jaka 03/9/26(金) 10:14

【8001】こうでしたか？ Jaka 03/9/26(金) 10:24

【8002】Re:こうでしたか？ こじこじ 03/9/26(金) 11:05

【8004】Re:こうでしたか？ Jaka 03/9/26(金) 11:51

【8007】Re:こうでしたか？ こじこじ 03/9/26(金) 13:02

【8010】Re:こうでしたか？ Jaka 03/9/26(金) 14:08

【8011】Re:こうでしたか？ こじこじ 03/9/26(金) 14:37

【8014】Re:こうでしたか？ Jaka 03/9/26(金) 15:33

【8043】Re:こうでしたか？ こじこじ 03/9/27(土) 17:15

【8062】この上、このまんまだと無限ループになる時... Jaka 03/9/29(月) 9:42

【8026】Re:セルの値をファイル名に しのしの 03/9/26(金) 17:32

【8045】Re:セルの値をファイル名に こじこじ 03/9/27(土) 17:28


	【7962】セルの値をファイル名に

こじこじ - 03/9/25(木) 14:25 -


	引用なし

	パスワード

こんにちわ
ExcelVBAをいつも参考にさせて頂いてます

セルの値をファイル名にしたいのですが
パスの関係や次のファイルへの移り方など
わかりません。

CドライブのWORKの中にプログラム実行ファイル（ｘｌｓ）と台帳というフォルダをおきます。台帳フォルダの中は複数のｘｌｓファイルがあって、そのファイルの
あるセルの値をそのファイル名にしたい。この処理を台帳ファイルの中のすべてのファイルにかけたいのですが、どうすればよいのでしょうか？

処理の際　整数で入っている値を三桁の０詰めにしてからファイル名にしたいのですが・・・・。

どなた宜しくお願いします.


	【7975】Re:セルの値をファイル名に

Jaka - 03/9/25(木) 16:52 -


	引用なし

	パスワード

こんにちは。
こう言うこと？
フォルダパスは直してください。
ファイル名を変更してしまいますので、テスト環境か予備を作ってから行って下さい。

Sub ffai2()
　　FldName = "C:\Windows\ﾃﾞｽｸﾄｯﾌﾟ\台帳\"
　　FalName = Dir(FldName)
　　Do Until FalName = ""
　　　 CelA1 = Application.ExecuteExcel4Macro("'" & FldName & "[" & FalName & "]Sheet1'!R1C1")
　　　 Name FldName & FalName As FldName & Format(CelA1, "000") & ".xls"
　　　 FalName = Dir()
　　Loop
End Sub


	【7976】Re:セルの値をファイル名に

Jaka - 03/9/25(木) 16:59 -


	引用なし

	パスワード

良く見たら、ファイルの識別をしていないので

if right(ファイル名,3)="xls" or right(ファイル名,3)="XLS" then

とか、入れるのも忘れないで下さい。


	【7984】Re:セルの値をファイル名に

こじこじ - 03/9/25(木) 19:40 -


	引用なし

	パスワード

返信ありがとうございます。
早速やってみましたが、変化はありませんでした

Sub ボタン1_Click()

　　 FldName = "C:\work\台帳\"
　　FalName = Dir(FldName)
　　Do Until FalName = ""
　　　　CelA1 = Application.ExecuteExcel4Macro("'" & FldName & "[" & FalName & "]農道台帳(調書)'!R1C1")
　　　　Name FldName & FalName As FidName & Format(CelA1, "000") & ".xls"
　　　　FalName = Dir()
　　Loop
　　
End Sub

このように書いてみたのですが・・・・
おくれましたが、OSはXPで、Excelは2002をつかってます

あとファイルの識別のコードはどこにいれればよいのかわかりません

宜しくおねがいします（T＿T)


	【8000】Re:セルの値をファイル名に

Jaka - 03/9/26(金) 10:14 -


	引用なし

	パスワード

こんにちは。
続きの質問に新規にスレッドを作らないで下さい。
新規に作った方を削除してください。

Name FldName & FalName As FidName & Format(CelA1, "000") & ".xls"
　　　　　　　　　　　　　　　↑
　　　　　　　　　　　　　FldName　すみません間違っていました。

Sub ボタン1_Click()
　　Dim FldName As String, FalName As String, CelA1 As string
　　FldName = "C:\work\台帳\"
　　FalName = Dir(FldName)
　　Do Until FalName = ""
　　　 CelA1 = Application.ExecuteExcel4Macro("'" & FldName & "[" & FalName & "]農道台帳(調書)'!R4C14")
　　　 Name FldName & FalName As FldName & Format(CelA1, "000") & ".xls"
　　　 FalName = Dir()
　　Loop
End Sub


	【8001】こうでしたか？

Jaka - 03/9/26(金) 10:24 -


	引用なし

	パスワード

>Sub ボタン1_Click()
>　　Dim FldName As String, FalName As String, CelA1 As string
　　 Dim Cnt As Long
>　　FldName = "C:\work\台帳\"
>　　FalName = Dir(FldName)
>　　Do Until FalName = ""
　　　　Cnt = Cnt + 1
>　　　 CelA1 = Application.ExecuteExcel4Macro("'" & FldName & "[" & FalName & "]農道台帳(調書)'!R4C14")
>　　　 Name FldName & FalName As FldName & Format(CelA1, "000") & ".xls"
>　　　 FalName = Dir()
>　　Loop
　　 if Cnt = 0 then
　　　　MsgBox "対象ファイルがありません"
　　 End if
>End Sub

FileSearchの方が良かったんでしょうか？


	【8002】Re:こうでしたか？

こじこじ - 03/9/26(金) 11:05 -


	引用なし

	パスワード

すいません、新規投稿のほうは消しておきます。

以下のように直してみたのですが
MsgBox（対象ファイルがありません）が表示されます
処理は最後までいってるってことですよね？
台帳フォルダには３つぐらいファイルをおいてあるのですが・・・。

Sub ボタン1_Click()

　　Dim FldName As String
　　Dim FalName As String
　　Dim CelA1 As String
　　Dim Cnt As Long
　　
　　 FldName = "C:\work\台帳\"
　　 FalName = Dir(FldName)
　　
　　 'Set fs = Application.FileSearch
　　　　　 ' With fs
　　　　　　　　'.LookIn = FldName
　　　　　　　　'.Filename = "*.XLS"

　　
　　Do Until FalName = ""
　　　　Cnt = Cnt + 1
　　　　　Right(FalName, 3) = "xls" Or Right(FalName, 3) = "XLS"
　　　　　　CelA1 = Application.ExecuteExcel4Macro("'" & FldName & "[" & FalName & "]農道台帳(調書)'!R4C14")
　　　　　　Name FldName & FldName As FidName & Format(CelA1, "000") & ".xls"
　　　　　　FalName = Dir()
　　Loop
　　　　If Cnt = 0 Then
　　　　
　　　　　　MsgBox "対象ファイルがありません"
　　　　End If
　　
End Sub


	【8004】Re:こうでしたか？

Jaka - 03/9/26(金) 11:51 -


	引用なし

	パスワード

抜けてた所があったんで、二度目。

▼こじこじさん：
>以下のように直してみたのですが
>MsgBox（対象ファイルがありません）が表示されます
>処理は最後までいってるってことですよね？
>台帳フォルダには３つぐらいファイルをおいてあるのですが・・・。

「以下のように直して．．」コードは消しましたが、
「MsgBox（対象ファイルがありません）が表示されます」
直されたコードは、エラーになって動かないと思いますが．．．。
本当にMsgBoxが表示されるんでしょうか？
私のポカもありますが、ちゃんと読んでますか？
FidNameの間違いも直してないみたいだし。

Sub ボタン1_Click()
　　Dim FldName As String, FalName As String, CelA1 As String
　　Dim Cnt As Long
　　FldName = "C:\work\台帳\"
　　If Dir(Left(FldName, Len(FldName) - 1), vbDirectory) = "" Then
　　　 MsgBox "フォルダがありません。"
　　　 End
　　End If
　　FalName = Dir(FldName)
　　Do Until FalName = ""
　　　 If Right(FalName, 3) = "xls" Or Right(FalName, 3) = "XLS" Then
　　　　　Cnt = Cnt + 1
　　　　　CelA1 = Application.ExecuteExcel4Macro("'" & FldName & "[" & FalName & "]農道台帳(調書)'!R4C14")
　　　　　Name FldName & FalName As FldName & Format(CelA1, "000") & ".xls"
　　　 End If
　　　 FalName = Dir()
　　Loop
　　If Cnt = 0 Then
　　　 MsgBox "対象ファイルがありません"
　　End If
End Sub


	【8007】Re:こうでしたか？

こじこじ - 03/9/26(金) 13:02 -


	引用なし

	パスワード

たびたびすいません
今度は間違いないように返信されたものを
コピーしました。

これで間違いないと思いますが
CelA1 = apprication.executeExcelのところで
型が違うとエラーがでます。

variantにしてみましたが、ダメでした。

宜しくおねがいします


	【8010】Re:こうでしたか？

Jaka - 03/9/26(金) 14:08 -


	引用なし

	パスワード

ExecuteExcel4Macroは、止めました。
難しすぎるんじゃないかと思います。
シート名を統一してますか？
そこまでのエラーチェック等は入れていません。
これでもエラーになると思いますが．．．。

Sub ボタン1_Click()
　　Dim FldName As String, FalName As String, OPWBk As Workbook
　　Dim ReNameSt As String
　　Application.ScreenUpdating = False
　　FldName = "C:\work\台帳\"
　　FalName = Dir(FldName)
　　Do Until FalName = ""
　　　 If Right(FalName, 3) = "xls" Or Right(FalName, 3) = "XLS" Then
　　　　　Cnt = Cnt + 1
　　　　　Set OPWBk = Workbooks.Open(FldName & FalName)
　　　　　ReNameSt = OPWBk.Sheets("農道台帳(調書)").Range("N4").Value
　　　　　OPWBk.Close (False)
　　　　　DoEvents
　　　　　Name FldName & FalName As FldName & Format(ReNameSt, "000") & ".xls"
　　　　　FalName = Dir()
　　　 End If
　　Loop
　　If Cnt = 0 Then
　　　 MsgBox "対象ファイルがありません"
　　End If
　　Application.ScreenUpdating = True
　　Set OPWBk = Nothing
End Sub


	【8011】Re:こうでしたか？

こじこじ - 03/9/26(金) 14:37 -


	引用なし

	パスワード

jakaさんほんとにありがとうございます
まだ解決したわけではありませんが
自分に長々と付き合っていただいて感謝です

まだ返信の内容を実行していませんが
その前に確認しておきたいことがありまして

セルが結合している状態と、セルが結合していない状態とでは
書き方が違うのしょうか？
いまさらと思ったらすいません。
取得したい値のセルは結合していました。

このことでかなり違うのでしたら
本当にすいません。


	【8014】Re:こうでしたか？

Jaka - 03/9/26(金) 15:33 -


	引用なし

	パスワード

▼こじこじさん：
>セルが結合している状態と、セルが結合していない状態とでは
>書き方が違うのしょうか？
>このことでかなり違うのでしたら
>本当にすいません。

どう言う風に受取ったら良いのか良く解りませんが．．．。

値の取得などは、結合セルの左上に当たるセルのアドレスを参照すれば問題はないと思いますが、それ以外だったら問題はあると思います。
エクセルVarによっても変わると思いますし、自分で色々テストなさるのが１番良いと思います。


	【8026】Re:セルの値をファイル名に

しのしの - 03/9/26(金) 17:32 -


	引用なし

	パスワード

Jakaさん、割り込み失礼します。

こじこじさん、こんにちは。
こじこじさんって、次のスレッドの方と同一人物ですか？
　
【1771】レコードの値をExcelのファイル名に　
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=1771;id=access

だとしたら、向こうを閉じるとかしてくださいね。
ケッコー悲しーです。
万一、同一ネームで人違いでしたら、ご容赦ください。
ACCESS用に待機していたコードをこちら用に書き換えてみました。

Microsoft ActiveX DataObjects　2.5 Library
Microsoft Scripting Runtime
を参照しています。

Sub Main()
On Error GoTo HandleErr
　　Dim obj As Scripting.FileSystemObject
　　Dim acnXL As ADODB.Connection
　　Dim iFile　 As Scripting.File
　　Dim newName As String
　　Dim strpath As String
　　
　　Set obj = New Scripting.FileSystemObject
　　Set acnXL = New ADODB.Connection
　　With acnXL
　　　　.Provider = "Microsoft.Jet.OLEDB.4.0"
　　　　.Properties("Extended Properties").Value = "Excel 8.0;HDR=NO;"
　　End With
　　
　　strpath = "C:\work\台帳\"

　　For Each iFile In obj.GetFolder(strpath).Files
　
　　　　'検索条件にあうものだけを取得して下さい。
　　　　'現状では.全角でも半角でも000-999までを取得します。
　　　　If UCase(iFile.Name) Like "###.XLS" Then
　　　　　　　　
　　　　　　newName = getNewName(acnXL, iFile.Path)
　　　　　　If newName <> "" Then
　　　　　　　　iFile.Name = newName
　　　　　　End If
　　　　End If
　　Next
　　
　　If acnXL.State <> adStateClosed Then
　　　　　　acnXL.Close
　　End If
　　Set acnXL = Nothing

　　Set obj = Nothing
　　Exit Sub
HandleErr:
　　MsgBox Err.Description
　　Resume EndProc
　　
EndProc:
On Error Resume Next
　　Set obj = Nothing
　　If acnXL Is Nothing = False Then
　　　　If acnXL.State <> adStateClosed Then
　　　　　　acnXL.Close
　　　　End If
　　　　Set acnXL = Nothing
　　End If
End Sub

Private Function getNewName( _
　ByRef racn As ADODB.Connection, _
　ByVal vstrConnString As String) As String
　　Dim ars　　　　 As ADODB.Recordset
　　Dim SQLstring　　　 As String　　　　　 'SQL文
　　Dim varNewName　　　As Variant
On Error GoTo HandleErr
　　
　　'シート接続
　　racn.ConnectionString = vstrConnString
　　racn.Open
　　SQLstring = "SELECT *" & vbNewLine _
　　　　　　　　& "FROM [農道台帳(調書)$N4:N4]" & vbNewLine
　　Set ars = New ADODB.Recordset
　　ars.Open SQLstring, racn, adOpenStatic
　　
　　
　　If ars.BOF = True And ars.EOF = True Then
　　　 getNewName = ""
　　Else
　　　　ars.MoveFirst
　　　
　　　　'ここで、取得した値（入力値）が正しいかどうかの処理を入れてください。
　　　　'今は取得値が半角or全角の処理をしていないので、
　　　　'混在状況ではエラーになります。
　　　　If IsNull(ars.Fields(0).Value) Then
　　　　　　getNewName = ""
　　　　Else
　　　　　　getNewName = VBA.Format(ars.Fields(0).Value, "000") & ".xls"
　　　　End If
　　End If
　　
　　ars.Close
　　Set ars = Nothing
　　racn.Close
　　racn.ConnectionString = ""

　　Exit Function

HandleErr:

　　MsgBox Err.Description
　　Resume EndProc
　　
EndProc:
On Error Resume Next
　　
　 If ars Is Nothing = False Then
　　　　If ars.State <> adStateClosed Then
　　　　　　ars.Close
　　　　End If
　　　　Set ars = Nothing
　　End If
　　If racn.State <> adStateClosed Then
　　　　racn.Close
　　End If
　　
End Function


	【8043】Re:こうでしたか？

こじこじ - 03/9/27(土) 17:15 -


	引用なし

	パスワード

jakaさん返信おくれてすいません。
最後に送っていただいたものを試して
みましたが、エラーになりました。
そこからすこし自分でいじって
いろいろ悪戦苦闘を繰り返していたら
なんとかできる事ができました。

これもひとえに長々と付き合って頂いた
jakaさんのおかげです。
勉強させて頂きました。

本当にありがとうございました。


	【8045】Re:セルの値をファイル名に

こじこじ - 03/9/27(土) 17:28 -


	引用なし

	パスワード

しのしのさん、私はアクセスの方での投稿と
同一人物です、ご迷惑をおかけいたしました。

正直アクセスで質問すればいいのか
エクセルの方で質問すればいいのか
（アクセスでプログラムを組むのか
　エクセルでプログラムをくむのか）
さえもわからなかったので今回の
ご迷惑にいたったのだと思います。
すべては私の勉強不足がもとでした。

せっかく解決策を用意して頂いてたのに
本当にすいません。ですが、無駄にするような
事はしませんので安心してください。
今後それを参考にする機会が必ずくると
おもいます。その時使わせていただきます。

ありがとうございました。


	【8062】この上、このまんまだと無限ループになる...

Jaka - 03/9/29(月) 9:42 -


	引用なし

	パスワード

申し訳ございません。

FalName = Dir()　をIF文から外に出さないと、状況によって無限ループに入ってしまいます。

何で中に入れちゃったのか不明？？

>Sub ボタン1_Click()
>　　Dim FldName As String, FalName As String, OPWBk As Workbook
>　　Dim ReNameSt As String
>　　Application.ScreenUpdating = False
>　　FldName = "C:\work\台帳\"
>　　FalName = Dir(FldName)
>　　Do Until FalName = ""
>　　　 If Right(FalName, 3) = "xls" Or Right(FalName, 3) = "XLS" Then
>　　　　　Cnt = Cnt + 1
>　　　　　Set OPWBk = Workbooks.Open(FldName & FalName)
>　　　　　ReNameSt = OPWBk.Sheets("農道台帳(調書)").Range("N4").Value
>　　　　　OPWBk.Close (False)
>　　　　　DoEvents
>　　　　　Name FldName & FalName As FldName & Format(ReNameSt, "000") & ".xls"
>　　　 End If
>　　　 FalName = Dir()　 '←ここにしないと.xls以外のファイルがあった場合
　　　　　　　　　　　　　'　無限ループになります。
>　　Loop
>　　If Cnt = 0 Then
>　　　 MsgBox "対象ファイルがありません"
>　　End If
>　　Application.ScreenUpdating = True
>　　Set OPWBk = Nothing
>End Sub


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

12903 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free