フォルダ内にあるファイル(xlsx)を1つのファイルごとに分類したいため、
そのファイル名と同名のフォルダを元のフォルダ内に新たに作成し、そこに保存したいという
下記のマクロを見つけて動かしてみたのですが、

FileCopy FPath & "\" & TargetFile, FPath & "\" & DName  & "\" & TargetFile
の箇所でファイルが存在しないと出ました。

色々と調べた結果、サーバーの中にあるファイルを作ろうとしているのですが
サーバーの階層が深く取得するパス名が300文字になっていたので
Dir関数だとエラーになることが判明し、対策として
ショートパスへ変換する方法やFSOを使って行えば解決するという所までは
調べたのですが、上手くいきません。

分かる方がいればアドバイスを頂ければと思い質問をさせて頂きました。
宜しくお願い致します。




Sub フォルダ作成()
  Dim FPath, TargetFile, DName

  FPath = Range("A1").Value
'セルのA1にサーバーのパスを記載しています

\\TEST\TESTファイル\管理項目\管理簿\各担当部署\確認事項\
上記の記載は例ですが本来の記載はかなり長く、260文字くらいあります。

  If FPath = "" Then Exit Sub
  TargetFile = Dir$(FPath & "\*.xlsx")
  Do While TargetFile <> ""
   DName = Left(TargetFile, InStrRev(TargetFile, ".") - 1)

   MkDir FPath & "\" & DName
ファイル名と同名のフォルダをサーバーに作成するのは成功しています。

   FileCopy FPath & "\" & TargetFile, FPath & "\" & DName _
      & "\" & TargetFile
上記の部分でエラーが出ており、パス名が長いためエラーになっています。


   Kill FPath & "\" & TargetFile
   TargetFile = Dir$
  Loop

 End Sub


Dim fso As New FileSystemObject
ファイルオブジェクトを使い、ショートパスにすればという
所までは調べたのですが、そこからどう繋げていいか不明なので
お手数ですがご教授願えないでしょうか?

A 回答 (1件)

このご質問の回答としては、私は、以下のコードを提示しますが、何か別の方法があったような気がしてなりません。



Function shortName(ByVal FileName As String)
'ショートネイム用のユーザー定義関数
 Dim objFS As Object
 Dim objFile As Object
 Set objFS = CreateObject("Scripting.FileSystemObject")
 If Right(FileName, 1) <> "\" Then 'フォルダーとファイルの区分け
  Set objFile = objFS.GetFile(FileName)
 Else
  Set objFile = objFS.GetFolder(FileName)
 End If
 shortName = objFile.shortPath
End Function

使用例:
Sub TestLongFileName()
 Dim fn As String

 Dim dst As String
 fn = "---long Name file ----"
 fn = shortName(fn)
 If Dir(fn) = "" Then
  MsgBox "ファイルが見つかりません", vbCritical
  Exit Sub
 End If

 dst = ""---long Name Path ----"" '末尾に¥を入れないとエラーが出ます。
 dst = shortName(dst)
FileCopy fn, dst
' ' Shell ("cmd.exe /c Copy " & fn & " " & dst)
End Sub
    • good
    • 0
この回答へのお礼

返答ありがとうございます。
元のマクロと組み込んでショートネイム用のユーザー定義関数を使い
ファイルのパスを取得することは出来ました。

細かい所の調整は行って色々と試したいと思います。
アドバイスありがとうございました。

お礼日時:2017/05/17 19:19

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aと関連する良く見られている質問

QVBAとロングファイル名

EXCELのVBAで、「C:\My Documents」のようなロングファイル名を
「C:\Mydocu~1」のような昔のファイル形式にする方法を教えてください。

例えば
ThisWorkbook.Pathで得たパス名がロングファイルだった場合です。


目的は、ある古い別アプリをShellで起動させたいのですが、それの
引数に昔のファイル形式で色々なパスを渡さないといけないのです。
(そのアプリがロングファイル名に対応していない)

ヘルプとか見たんですけど分からないので教えてください。
お願いします。

Aベストアンサー

GetShortPathNameというAPIを使用します。VBAではAPIを使用する前に定義を
書く必要があります。定義は次の通りです。

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" ( _
ByVal LongPath As String, _
ByVal ShortPath As String, _
ByVal ShortPathSize As Long) As Long

以下はサンプルです。

Dim FileName As String * 512
GetShortPathName "Z:\My Document\audio.wav", ShortName, 512
MsgBox Left(FileName, InStr(FileName, vbNullChar) - 1)

Qファイル名が長すぎる場合のコピーや移動は?

200ギガを越えるHDDのバックアップをしていました。

最新のWindows 8 なので油断してしまい、表題の件に関わる警告のウィンドウが出たときにスキップの操作をしてしまいました。つまり、古いHDDの中に取り出せないファイルが残ってしまったのです。

何文字以上がコピペなどの規制にかかるのでしょうか?

コピーできなかったファイルを探し出す方法を教えてください。
ファイル数は88万以上あり、手動ではできそうにもありません。

Aベストアンサー

パス(C:\a.jpgなら8文字)を含めて半角で256文字、全角は1文字で半角2文字分で数えます。
ただ、制限文字数は他の要素(コピー時の内部処理的なコマンド追加)で早まったりするので、240文字程度までに抑えておくのが良いでしょう。

ファイル名が少々長い(40文字とか)程度でも、深い階層に置いていたり、途中にあるフォルダの名前も長かったり、ファイルやフォルダ名が全角だったりすると、意外と簡単に制限に引っかかります。

良くあるのが、最初は浅い階層に置いているファイルを、整理の為に階層の一番下に置くことを繰り返していると簡単に10階層以上下になって文字数オーバーとかです。

bunbackupで差分コピーを使うと、エラーが発生してコピーできなかったファイルがわかります。すでにほとんどのBackupが終わっているならば新旧HDDの比較だけなので、そう時間はかからないと思いますよ。

QEXCELファイルのカレントフォルダを取得するには?

EXCELファイルのカレントフォルダを取得するには?

C:\経理\予算.xls

D:\2005年度\予算.xls

EXCEL97ファイルがあります。

VBAで
  カレントフォルダ名
(C:\経理\,D:\2005年度\)
を取得する事は可能でしょうか?

CURDIRでは上手い方法が見つかりませんでした。

Aベストアンサー

こんばんは。
Excel97 でも、同じですね。以下で試してみてください。

Sub test()
'このブックのパス
a = ThisWorkbook.Path
'アクティブブックのパス
b = ActiveWorkbook.Path
'Excelで設定されたデフォルトパス
c = Application.DefaultFilePath
'カレントディレクトリ
d = CurDir
MsgBox "このブックのパス   : " & a & Chr(13) & _
   "アクティブブックのパス: " & b & Chr(13) & _
   "デフォルトパス    : " & c & Chr(13) & _
   "カレントディレクトリ : " & d & Chr(13)
End Sub

QEXCEL VBA で現在開いているブックのファイル名を取得する方法

EXCEL2003 VBAで業務を簡素化するために、現在開いているブックのファイル名を取得する方法が分かりません。
作業手順をマクロを使って処理していますが、オリジナルのワークブックをファイル名を変えて保存し、以後、このワークブックを読み込んで使用しています。
このときのVBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり、以後の業務に使用できません。
常にファイル名を取得出来るVBAをどなたか、教えて下さい。

Aベストアンサー

>現在開いているブックのファイル名
 ちょっと曖昧な表現かなぁという気もいたしますが、VBAが書いてあるブックのブック名は
ThisWorkbook.Name
で、現在 "アクティブにして" 操作対象になっているブックの名前は
ActiveWorkbook.Name
ですね。

 しかし、
>VBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり
というような文脈からすると、
ThisWorkbook.Name
の方ですかね。

QACCESSからEXCEL起動時、パス名は短い名前でないといけないの?

ACCESS2003からEXCEL2003をVBAで起動するコードを書いてます。

SetApplName = "c:\Program Files\Microsoft Office\office11\excel.exe /r c:\docume~1\alluse~1\docume~1\毎日の数字.xls"
Call Shell(SetApplName, 1)

のように指定していますが、いちいち短い名前を指定しないと
いけないようで、面倒で困っています。
長いパス名を短いパス名に変換するような関数等はありませんか?
他にもっと簡便な方法があればあわせてご教示ください。

Aベストアンサー

こんにちは。KenKen_SP です。

Shell に渡すパスに空白があるとそこでコマンド区切りとして解釈され、誤動
作します。8.3 形式のショートパスを使う理由はそこにあるのですが、空白を
含むロングパスであってもパスを ”” で括れば OK です。

もちろん、ロングパスとショートパスの相互変換は API を使えば可能ですが...
Shell で Excel を起動する理由は?

ご提示のコードだと、Excel のバージョンやインストールパスなどが変われば
動かないコードになってしまいますよ? 例えば、

 Excel2002  C:\Program Files\Microsoft Office\Office10\Excel.exe
 Excel2003  C:\Program Files\Microsoft Office\Office11\Excel.exe

のように、標準インストールでもバージョンでフォルダ名が違うし、D:\ などの
別ドライブにインストールされる可能性もあるので、レジストリから Excel.exe
のパスを調べるハメになりますね。

Access + Excel の連携なら CreateObject か GetObject が一般的に使われる
方法だと思います。単に読み取り専用で開きたいだけなら、下記のようなコード
になります。

Sub Sample()

  Dim xlApp As Object ' Excel.Application
  Dim Wb  As Object ' Excel.Workbook
  
  Set xlApp = CreateObject("Excel.Application")
  With xlApp
    ' 可視化
    .Visible = True
    ' ブックを読み取り専用で開く
    Set Wb = .Workbooks.Open( _
        FileName:="C:\Sample.xls", _
        ReadOnly:=True)
    ' 処理
    ' イミディエイトウインドウにブック名を表示してみる
    Debug.Print Wb.Name
  End With
  
  ' ※1 Excel を開いたままプロシージャを終了する場合
  Set Wb = Nothing
  Set xlApp = Nothing
  
  ' ※2 ブックを閉じ Excel も終了させる場合
  ' オブジェクト変数の開放をちゃんとしないと Excel を
  ' xlApp.Quit で終了させても プロセス が残ってしまう

  'Wb.Close
  'Set Wb = Nothing
  'xlApp.Quit
  'Set xlApp = Nothing

End Sub

こんにちは。KenKen_SP です。

Shell に渡すパスに空白があるとそこでコマンド区切りとして解釈され、誤動
作します。8.3 形式のショートパスを使う理由はそこにあるのですが、空白を
含むロングパスであってもパスを ”” で括れば OK です。

もちろん、ロングパスとショートパスの相互変換は API を使えば可能ですが...
Shell で Excel を起動する理由は?

ご提示のコードだと、Excel のバージョンやインストールパスなどが変われば
動かないコードになってしまいますよ? 例えば、

 Excel2002 ...続きを読む

QExcelを使って行列変換をしたい(大量件数)

先日質問させていただいたものです。
さらなる加工が必要になりました。

例えば、
◆test
aaaaaa
iiiiiiiiiiiii
uuuuu
eeeee
ooooo
◆test2
kaaaaa
kiiiiiiiiiii
kuuuuu
keeeee
kooooo
...

これらのデータを
◆test aaaaaa
    iiiiiiiiiiiiii
    uuuuuu
eeeeee
oooooo
◆test2 kaaaaa
     kiiiiiiiiiii
     kuuuu
     keeeee
     koooooo

に変換はできたのですが、今度は
◆test aaaaaaaa iiiiiiiiiii uuuuuuuuuuu eeeeeee oooooo
◆test2 kaaaaaa kiiiiiiiii kuuuuuuuuu keeeeee koooooooo

のように変換する必要がでてしまいました。

マクロなどで一括で変換できないでしょうか。
当方知識が乏しいため困っております。

先日質問させていただいたものです。
さらなる加工が必要になりました。

例えば、
◆test
aaaaaa
iiiiiiiiiiiii
uuuuu
eeeee
ooooo
◆test2
kaaaaa
kiiiiiiiiiii
kuuuuu
keeeee
kooooo
...

これらのデータを
◆test aaaaaa
    iiiiiiiiiiiiii
    uuuuuu
eeeeee
oooooo
◆test2 kaaaaa
     kiiiiiiiiiii
     kuuuu
     keeeee
     koooooo

に変換はできたのですが、今度は
◆test aaaaaaaa iiiiiiiiiii uuuuuuuuuuu eeeee...続きを読む

Aベストアンサー

こんにちは!

別シートに表示しても良いですか?
元データはSheet1のA列にあり、Sheet2に表示するとします。
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, cnt As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.ClearContents
With Worksheets("Sheet1")
For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
If InStr(.Cells(i, "A"), "◆") > 0 Then
cnt = cnt + 1
wS.Cells(cnt, "A") = .Cells(i, "A")
Else
wS.Cells(cnt, Columns.Count).End(xlToLeft).Offset(, 1) = .Cells(i, "A")
End If
Next i
End With
End Sub

こんな感じではどうでしょうか?m(_ _)m

こんにちは!

別シートに表示しても良いですか?
元データはSheet1のA列にあり、Sheet2に表示するとします。
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, cnt As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.ClearContents
With Worksheets("Sheet1")
For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
If InStr(.Cells(i, "A"), "◆") > 0 Then
cnt = cnt + 1
wS.Cells(...続きを読む

Q<エクセル>2つのデータに間違いがないかをチェックしたい

エクセルで入力したデータが、ルールに基づいて正しく入力できているかどうかを確認するような関数はありますか?

例として(添付画像もつけさせていただきました)「粉薬」と「飲薬」を入力し、各容量を入力します。
「粉薬」と「××g」、「飲薬」と「××」は必ずセットで入力されていることが必須です。
もし誤って「粉薬」のときに「××」と入力をした場合に、間違った入力がされていることが表示されるような関数はありますでしょうか?
枠外に〇や×として表示される
セルに色がつく・・・等

色々検索をして試してみたのですがうまくいきません。
VBAなども出てきたのですが私自身知識が全くないことと、作成したデータをあまりエクセルが得意ではない人が使う可能性などを考え、できれば関数などでできれば・・・と考えています。

Aベストアンサー

=IF(NOT(ISERROR(FIND("粉薬",B2))),IF(NOT(ISERROR(FIND("g",C2))),"○","×"),"・")
b2に粉薬の文字がある場合で、かつ、(c2にgの文字がある場合には、○を表示、ない場合は×を表示)、左記以外は・を表示

Q情報系の授業の課題なのですが、思ったようにできず困っています。エクセル(2010)のvbaでネットで

情報系の授業の課題なのですが、思ったようにできず困っています。エクセル(2010)のvbaでネットでの拾い物を使って改変して使用しているのですが、処理が通らず困っております。

Sub Pokemon()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim hizuke As String, wnum As String
Dim rng As Range
Dim i As Long, imax As Long
Dim j As Variant, c As Long
Dim sname As String
Dim fsh As Variant
fsh = Array("lightening", "fire", "water", "leaf", "wind", "dragon")
hizuke = InputBox("ポケモンを捕まえた日付を入力して下さい")
If hizuke = "" Then Exit Sub
If IsDate(hizuke) = False Then
MsgBox "日付不正"
Exit Sub
End If
Set sh1 = Worksheets("ポケモン図鑑")
With sh1
Set rng = .Range(.Cells(4, 5), .Cells(4, .Cells(4, Columns.Count).End(xlToLeft).Column))
End With
j = Application.Match(CLng(CDate(hizuke)), rng, 0)
If IsError(j) Then
MsgBox "該当日付がありません"
Exit Sub
End If
wnum = InputBox("選択した日付が何週目になるかを入力して下さい")
If wnum = "" Then Exit Sub
If wnum < 1 Or wnum > 5 Then
MsgBox "週不正"
Exit Sub
End If
Application.ScreenUpdating = False
c = wnum * 2 + 3
For Each sh2 In Worksheets
For i = 0 To 5
If sh2.Name = fsh(i) Then
With sh2
If .Cells(5, c) <> "" Then
.Range(.Cells(5, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).ClearContents
End If
End With
Exit For
End If
Next i
Next sh2
With sh2
If .Cells(5, c) <> "" Then
.Range(.Cells(5, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).ClearContents
End If
End With
End If
Next sh2
With sh1
imax = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 6 To imax
If .Range("A" & i).Value <> "" Then
sname = .Range("D" & i).Value
Select Case sname
Case "water", "leaf", "wind", "dragon"
Case Else
If (Left(sname, 3) = "Lightning" Or Left(sname, 3) = "fire") And InStr(sname, "伝説ポケモン") = 0 Then
sname = Left(sname, 3) & "aaa"
Else
sname = ""
End If
End Select
If sname <> "" Then
Set sh2 = Worksheets(sname)
sh2.Cells(sh2.Cells(Rows.Count, c).End(xlUp).Row + 1, c).Value = .Cells(i, j + 4)
End If
End If
Next i
For i = 32 To 40
Set sh2 = Nothing
Select Case i
Case 1
Set sh2 = Worksheets("lightening")
Case 2
Set sh2 = Worksheets("fire")
Case 4
Set sh2 = Worksheets("water")
Case 6
Set sh2 = Worksheets("leaf")
Case 7
Set sh2 = Worksheets("wind")
Case 9
Set sh2 = Worksheets("dogagon")
End Select
If Not sh2 Is Nothing Then
.Cells(i, j + 4).Value = sh2.Cells(sh2.Cells(Rows.Count, c + 1).End(xlUp).Row, c + 1).Value
End If
Next i
End With
Application.ScreenUpdating = True
MsgBox "ポケモン抽出コピペ終わり!"
End Sub

友人からここが原因で通らないんじゃないの?
If (Left(sname, 3) = "Lightning" Or Left(sname, 3) = "fire") And InStr(sname, "伝説ポケモン") = 0 Then
sname = Left(sname, 3) & "aaa"
Else
……と指摘を受けたのですが、どう直せばいいのかよくわかりません。
誰がわかる方いらっしゃいますでしょうか。

情報系の授業の課題なのですが、思ったようにできず困っています。エクセル(2010)のvbaでネットでの拾い物を使って改変して使用しているのですが、処理が通らず困っております。

Sub Pokemon()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim hizuke As String, wnum As String
Dim rng As Range
Dim i As Long, imax As Long
Dim j As Variant, c As Long
Dim sname As String
Dim fsh As Variant
fsh = Array("lightening", "fire", "water", "leaf", "wind", "dragon")
hizuke = InputBox("ポケモンを捕まえた日...続きを読む

Aベストアンサー

If Left(sname, 3) = "Lig"
If Left(sname, 9) = "Lightning"
どちらでもTrueになりえます。
もちろんfireに関しても同じ配慮は必要ですし、、、
Lightning が大文字から始まっていてfireが小文字であることに問題があるかもしれませんし、、、

かぶっているものがなければ、左3文字判定でもよいと思います。

あと、、、
For i = 32 To 40
Select Case iでcase 1~case 9って、絶対にどれも引っ掛らないと思うけど、、、

何だろう、デバッグの方法で、ステップ実行とか、習っていないのかな?
自分が思う通りの動きをしているか見ながらやるとよいよ。
http://www.239-programing.com/excel-vba/basic/basic023.html

QエクセルVBAで#N/Aのようなエラー値を含むセルの検出は

エクセルVBAでセルに#N/Aのようなエラー値を含む場合Ifを使った構文で制御したいのですが、エラー値であるかどうかを調査するにはどうすれば良いでしょうか。教えてください。

Aベストアンサー

ワークシート関数のISERRORを使えばよいようです。

#N/A、#VALUE!、#REF!、#DIV/0!、#NUM!、#NAME?、#NULL! のいずれでもTRUEが返ります。

エラーの種類を検出するには、ERROR.TYPE関数を使用します。ただし、ERROR.TYPE関数でエラーのないセルを参照すると、#N/A が返ります。

詳細は、キーワード「エラー」または「IS関数」でヘルプをご参照ください。

VBAを使う場合は、CVErr 関数でエラー値を検出できます。
(詳細は、キーワード「セルのエラー値」で。)

Qエクセル マクロで指定フォルダを開く

エクセルにて
指定フォルダを開く、マクロがあれば教えて頂けないでしょうか。
よろしくお願いいたします。

Aベストアンサー

こんにちは。

こういうものですか?
開くフォルダを変えたいときは targ に与えるパスを変更します。

Sub OpenFolders()
Dim targ As String
targ = "C:\"
Shell "C:\Windows\Explorer.exe " & targ, vbNormalFocus
End Sub


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング

おすすめ情報