[[20210725145928]]　『フォルダ、ファイルはセルと同じ、すでにあったら』（製缶業です）　ページの最後に飛ぶ

『フォルダ、ファイルはセルと同じ、すでにあったら連番』（製缶業です）

困っています、なんとか教えて下さい。やりたいのは、セルB2に会社名が入っていて、その名前によってあらかじめ用意してある同じ会社名のフォルダの中に、D8×F8×G6(D8等にはセルの中の数字)というフォルダをなければ新しく作り、おなじD8×F8×G6というファイルをそのフォルダの中につくりたいのです。もしあれば、フォルダ名は同じで、ファイル名に連番(D8×F8×G6-1こんな感じ)を付けてそのフォルダに保存したいのですが、
各メーカーから箱の作成の注文が色々なサイズで来るのですが、同じサイズでも、内容が違っているためその都度、調べて、フォルダを作ってファイルをつくらないといけません。いろいろなネットや本を調べたのですが当方の勉強不足でわかりません、何卒宜しくお願いいたします。

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

＞いろいろなネットや本を調べたのですが当方の勉強不足でわかりません
おそらく、マクロの話にであろうとおもいますが、どの辺まではできているのですか？

ご質問から推察するに、ポイントは大きく分けて

 1) フォルダを作成する
 2) ファイルの存在をチェックする
 3) ファイル（ブック）を保存する

という３点になろうかとおもいます。このうち、

1)は「使用 OS：Windows10 」であればコマンドプロンプトの「MDコマンド」を利用するという手もあろうかと思います。

2)はDir関数を使ってみてはどうでしょうか

3)はマクロの記録で必要な命令を調べることができます。

もちろん上記に挙げた方法以外でも解決可能だと思いますので、まずは現状のコードを示してわからない部分をピンポイントで聞くようにするとより具体的なアドバイスが得られると思いますのてまずはトライしてみてはどうでしょか。

（もこな２） 2021/07/25(日) 16:47

 こんばんは　＾＾
多分、このままでは、お役に立たないとはおもいますが
[どんどん増殖していきます。。。乳酸菌みたい＾＾；]
何かの足しにでも。Dir関数、とMkdirステートメント使
ってみました。
このブックと同じフォルダに、Sheet1 のB2の値と同じ名前のフォルダ
が存在することが前程です。
Option Explicit
Sub zOneInstance()
    Dim fD1           As String
    Dim fD2           As String
    Dim fDx           As String
    Dim fNm           As String
    Dim i             As Long
    With Worksheets("Sheet1")
        fD1 = ThisWorkbook.Path & "\" & .Range("B2") & "\"
        fD2 = CStr(.Cells(8, 4) * .Cells(8, 6) * .Cells(8, 7))
    End With
    fDx = fD1 & fD2
    If Dir(fDx, vbDirectory) = "" Then
        MkDir (fDx)
    End If
    fDx = fDx & "\"
    If Dir(fDx & fD2 & ".xlsx") = "" Then
        fNm = fDx & fD2 & ".xlsx"
        Else
            Do
                i = i + 1
                fNm = Dir(fDx & fD2 & "-" & i & ".xlsx")
                If fNm = "" Then
                    fNm = fDx & fD2 & "-" & i & ".xlsx"
                    Exit Do
                End If
                If i Mod 24 = 0 Then DoEvents
            Loop
    End If
    Workbooks.Add.SaveAs fNm, 51
    ActiveWorkbook.Close False
End Sub
（隠居じーさん） 2021/07/25(日) 18:10

ありがとうございます
下記まではわかったのですが、会社名の入ったフォルダに入れる方法と同じ名前のファイルがあった時、型が違います、とエラーが出てしまうのですが

Sub test
Const mpath As String="F:￥"
Dim fpath As String
Dim wname As String
Dim fname As String
Dim tmp As String
Dim no As Integer
wname = Range("D8").Value & Range("F8").Value & Range("G8").Value
If Dir(mpath & wname. vbDirectory) = ""Then
MkDir mpath & wname
End If
fname = mpath & wname & "￥" & wname & ".xlsm"
If Dir(fname) = "" Then
ThisWorkbook.SaveAs Filename:=fname
Else
fpath = mpath & wname & "￥"
fname =Dir(fpath & "*.xlsm",vbNormal)
Do Until fname = ""
tmp = Mid(fname, InStrRev(fname,"￥")+1)
If Left(tmp,Len(fname)) = fname Then
If Left(tmp,Len(tmp) -5*1＞ no Then
no = no + 1
End If
End If
fname = Dir()
Loop
ThisWorkbook.SaveAs Filename:=fpath & wname & no & ".xlsm"
End If
MsgBox "終了"
End Sub

（製缶業です） 2021/07/25(日) 18:49

 こんばんは　＾＾
ちょい、こちらへの、転記ミス、みたいなのがありましたが
Ｆドライブのフォルダではなく、Ｆドライブのカレントに
出力されていますよ。＾＾；、当方ではエラーは出ませんが
ファイル名が変更されていないので、どんどん、上書きメッセージが
でて、上書きされる状態ですね、このへんを、改良されるといいですよ。
（隠居じーさん） 2021/07/25(日) 19:47

 失礼いたしました、
↑　￥が全て全角になっていましたですよ、全て半角に変換すれば
正常に動作しているようですよ、[Ｄドラの所定のフォルダ化下に
どんどん、増殖してますよ＾＾；]運用面は解りませんが。。。(#^.^#)ｖ

（隠居じーさん） 2021/07/25(日) 19:55

↑
Ｆドライブの間違いでした
m(__)m
（隠居じーさん） 2021/07/25(日) 19:56

 お題をお借りして練習させて頂きました。
 枝番は必ず-1から始まるのはご了承下さい。
 各会社名のフォルダは存在するのが前提です。

 Sub test()

  Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
  Dim FileName As String, FolderName As String, iFilePath As String

  FileName = Range("D8").Value & "×" & Range("F8").Value & "×" & Range("G8").Value
  FolderName = FSO.BuildPath("F:\", Range("B2") & "\" & FileName)
  ThisWorkbook.Save
  If FSO.FolderExists(FolderName) Then
    'ファイル名のフォルダが存在する場合
    Dim iFile As Object, buf As Long, cnt As Long
    For Each iFile In FSO.GetFolder(FolderName).Files
      buf = CLng(Mid(FSO.GetBaseName(iFile), InStr(FSO.GetBaseName(iFile), "-") + 1))
      If buf > cnt Then cnt = buf
    Next
    cnt = cnt + 1
    iFilePath = FSO.BuildPath(FolderName, FileName & "-" & cnt & ".xlsm")
    FSO.CopyFile ThisWorkbook.FullName, iFilePath
  Else
    'ファイル名のフォルダが無かった場合
    FSO.CreateFolder FolderName
    FSO.CopyFile ThisWorkbook.FullName, FolderName & "\" & FileName & "-1.xlsm"
  End If

 End Sub
（名無し） 2021/07/25(日) 20:01

皆様、本当にありがとうございます。
上手くいきました。
私も皆様にちょっとだけでも、追いつける様にがんばります

（製缶業です） 2021/07/25(日) 20:58

申し訳ありません。名無し様にご質問です、
家のパソコンでは、問題なく動作したのですが、会社のパソコンで使ってみたら、
エラーが出てしまいます。各企業のフォルダはデータサーバに入れてあります、
ファイルが見つかりませんとエラー画面が出て、デバッグすると下から3行目
Fso.Copy〜の行が黄色くなってました。なぜでしょう？よろしければ、ご指導
いただけないでしょうか

（製缶業です） 2021/07/31(土) 09:43

 データサーバのフォルダ階層に合わせてF:\は書き換えていらっしゃいますよね？
 ThisWorkbook.SaveCopyAs に変更するとどうなりますでしょうか。
 会社名のフォルダが無い場合作成するバージョンにしましたので、これで試していただけますか？

 Sub test()

  Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")

  ThisWorkbook.Save
  Const iParent As String = "F:\"
  Dim CorpName As String, FileName As String
  CorpName = Range("B2").Value
  FileName = Range("D8").Value & "×" & Range("F8").Value & "×" & Range("G8").Value
  If FSO.FolderExists(FSO.BuildPath(iParent, CorpName)) = False Then
    FSO.CreateFolder FSO.BuildPath(iParent, CorpName)
  End If

  Dim FolderName As String, iPath As String
  FolderName = FSO.BuildPath(iParent, FSO.BuildPath(CorpName, FileName))
  If FSO.FolderExists(FolderName) Then
    Dim iFile As Object, buf As Long, cnt As Long
    For Each iFile In FSO.GetFolder(FolderName).Files
      buf = CLng(Mid(FSO.GetBaseName(iFile), InStr(FSO.GetBaseName(iFile), "-") + 1))
      If buf > cnt Then cnt = buf
    Next
    iPath = FSO.BuildPath(FolderName, FileName & "-" & cnt + 1 & ".xlsm")
  Else
    FSO.CreateFolder FolderName
    iPath = FSO.BuildPath(FolderName, FileName & "-1.xlsm")
  End If
'  FSO.CopyFile ThisWorkbook.FullName, iPath
  ThisWorkbook.SaveCopyAs iPath

 End Sub
（名無し） 2021/07/31(土) 13:20

早速本当にありがとうございます。
フォルダは書き換えてます。
土日は会社がしまっているため、来週試してみます。
（製缶業です） 2021/07/31(土) 16:36

※注意

 すでに、隠居じーさんさんや名無しさんとの話が進んでいるようなので混乱防止のため一段落したあとでお読みください
 「2021/07/25(日) 18:49」のコードを拝見しての感想です。

■１
VBAの世界では基本的にシートやセル（オブジェクトといいます）を明示すれば、いちいち選択したりアクティブにしたりする必要はありません。
さらに、「標準モジュール」でシートの指定を省略すると、アクティブシートを指定したものとして扱われます。
したがって、きちんとオブジェクトを修飾（指定）するようにしたほうが良いでしょう。

■２
VBAでは、インデント（字下げ）を付けることに実行上の意味はありません。
ですが、適度にインデントを付けるようにすると可読性がアップしご自身のデバッグ作業効率がアップすると思いますので、こだわりが無ければインデントをつけるようにするとよいとおもいます。

■３
既に気づいておられるようですが、MkDirでフォルダを作ろうとする場合、すでに存在する場合や、親フォルダが無かったりすると実行時エラーになります。
「MDコマンド」もありますよとお伝えしたのは↑のことを踏まえてでした。

■４
当たり前ですが↓ですと自身を保存します。

 ThisWorkbook.SaveAs

しかし想像するにマクロを記述するブックは雛形のようなものなのでしょうから、コピーしたブック（シート）を保存されるようにしたほうがよいとおもいます。
さらに、保存するブックにマクロは不要だと思うので「xlsx」形式で保存したほうがよいとおもいます。

■５
ということを踏まえると↓のようなアプローチもあるとおもいます。
（完成品のプレゼントではなく、研究用として提示します）

    Sub さんぷる()
        Const ルートフォルダ As String = "F:\"
        Dim ベースファイル名 As String
        Dim フォルダパス As String
        Dim buf  As String
        Dim 枝番号 As Long
        Dim 保存ファイルパス As String

        ActiveSheet.Copy
        With Workbooks(Workbooks.Count).Worksheets(1)

            ベースファイル名 = .Range("D8").Value & "×" & .Range("F8").Value & "×" & .Range("G8").Value
            フォルダパス = ルートフォルダ & .Range("B2").Value & "\" & ベースファイル名

            '(1)フォルダを作成する
            With CreateObject("WScript.Shell").Exec("%ComSpec% /c MD " & フォルダパス)
                Do While .Status = 0
                    DoEvents
                Loop
            End With

            '(2)ファイルの存在をチェックする
            buf = Dir(フォルダパス & "\" & ベースファイル名 & ".xlsx")
            Do Until buf = ""
                枝番号 = 枝番号 + 1
                buf = Dir(フォルダパス & "\" & ベースファイル名 & "-" & 枝番号 & ".xlsx")
            Loop

            '(3)保存(して閉じる)
            If 枝番号 = 0 Then
                保存ファイルパス = フォルダパス & "\" & ベースファイル名
            Else
                保存ファイルパス = フォルダパス & "\" & ベースファイル名 & "-" & 枝番号
            End If
            .Parent.SaveAs Filename:=保存ファイルパス, FileFormat:=xlOpenXMLWorkbook
            .Parent.Close False
        End With
    End Sub

（もこな２） 2021/08/01(日) 13:08

名無し様へ何度もすいません。
最初に教えていただいた方なのですが最後を
ThisWorkbook.SaveCopyAs(FolderName&Filename
&,"-"&"1"&".xlsm") となおしたのですが、一度、ファイルを
閉じてフォルダも閉じて、また、最初から、ファイルを開くて
実行すると、フォルダは出来てるのですがその中にファイルが
ありません。ファイルを閉じない時は、2回目や、D8などのデータを変えても、
新しくフォルダとファイルは出来ます。
なぜでしょうか？
お忙しい中、何度も大変恐縮ですが、教えていただけないでしょうか。

（製缶業です） 2021/08/21(土) 10:17

 初回に保存するパスの指定をよく見直してください。
 今回提示されたコードには、抜けてるものがありますよ。
（名無し） 2021/08/21(土) 10:29

名無し様へ、何が抜けているか、今の私の実力では
分からないので教えていただけないでしょうか？
本当にすいません
（製缶業です） 2021/08/21(土) 11:31

 あなたが書き換える前の部分と書き換えた後の部分のそれぞれに、
 ファイルの保存先(パス)を指定する箇所がありますよね？
 そこをよく比較して見直してください。
 実力云々ではありません。
 --
 正直申しまして、前回修正したものについての報告もありませんし、
 自分でコード書き換えて、想定通り動かないと言われても、という気持ちでおります。

（名無し） 2021/08/21(土) 11:59

名無し様へ
本当にすいません。おかげで上手くいきました。
また、前回の修正していただいた事についても、報告せず
失礼しました。
ただ、名無し様には感謝の気持ちしかありません。
しかし、確かに名無し様の好意に甘え過ぎていました。
申し訳ありません。
こちらとしては、盆前後のバタバタで最初に教えていただいた
内容すら、ゆっくり勉強出来ていない状況ですが、今後も、
引き続き勉強していきたいと思いますので何卒、宜しくお願いいたします。

（製缶業です） 2021/08/21(土) 13:44

コメント返信：

[ 一覧(最新更新順) ]

[[20210725145928]] 『フォルダ、ファイルはセルと同じ、すでにあったら』（製缶業です） ページの最後に飛ぶ

[[20210725145928]]　『フォルダ、ファイルはセルと同じ、すでにあったら』（製缶業です）　ページの最後に飛ぶ