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の中にプログラム実行ファイル(xls)と台帳というフォルダをおきます。台帳フォルダの中は複数のxlsファイルがあって、そのファイルの
あるセルの値をそのファイル名にしたい。この処理を台帳ファイルの中のすべてのファイルにかけたいのですが、どうすればよいのでしょうか?

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

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

【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(対象ファイルがありません)が表示されます
処理は最後までいってるってことですよね?
台帳フォルダには3つぐらいファイルをおいてあるのですが・・・。


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(対象ファイルがありません)が表示されます
>処理は最後までいってるってことですよね?
>台帳フォルダには3つぐらいファイルをおいてあるのですが・・・。

「以下のように直して..」コードは消しましたが、
「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によっても変わると思いますし、自分で色々テストなさるのが1番良いと思います。

【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 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free