【最大10000ポイント】当たる!!質問投稿キャンペーン!

VBAの初心者です。

一日に数回、取引先に見積もりを送り、その元ファイルを送信時に作成したフォルダに保存しています。これらファイルを送信後に、バックアップフォルダにコピーしたいのです。

フォルダ構成:「」がフォルダ名
「年」(固定)
  「処理日時」(複数、1日に3~4回、日時は不特定)
    「完了」(固定 複数ある処理状況フォルダの内の1つ)
      「取引先名」(複数、ファイル名は不特定)
        見積ファイル(複数作成される)

例:2018\0801_1445\完了\○○社\〇〇社_商品A_0801.xlsx、〇〇社_商品B_0801.xlsx、...

複数保存されている処理日時フォルダのうち、作成日時が最新のフォルダ内の「完了」フォルダ内にある全ての取引先の全ての見積ファイルを所定のバックアップフォルダに、ごっそりコピーしたいのです。

上記の例では、最後に作成されたのが「0801_1445」フォルダであり、その中に5社分の取引先別のフォルダがあり、それぞれに3商品の見積もりファイルが保存されているとしたら、合計15ファイルをバックアップフォルダーにコピーする、という処理です。

ネットで調べて、DIR関数の再帰処理でサブフォルダを巡回するようなロジックを組んでみましたが、どうしてもうまく行きません。

本来であれば、ファイルの出力プログラムを改修すれば良いのですが、当方にプログラムの著作権が無いため、このような後付けの処理が必要になっています。

よろしくお願いいたします。

質問者からの補足コメント

  • ご回答ありがとうございます。
    1.他の周辺処理をVBAで組んでいること、実行するのがエンドユーザのため、できればVBAで実現したいと考えています。

    2.バックアップフォルダには、取り敢えずファイルを一律に並べてしまいます。その後の移しは、エンドユーザが自由にやる、という想定です。

    No.1の回答に寄せられた補足コメントです。 補足日時:2018/08/04 11:30

A 回答 (2件)

No.1です。


VBAで作成してみました、ご参考にどうぞ。
冒頭のコピー元、コピー先のパスは使用する環境に応じて書き換えて下さい。


-----ここから

'コピー元
Const SRC_FOLDER As String = "C:\2018"
'コピー先(バックアップ)
Const BACKUP_FOLDER As String = "C:\backup"

Sub バックアップ()
  Dim path As String
  Dim companies As Variant
  Dim company As Variant
  Dim fName As String
  
  '最新処理日時フォルダ名取得
  path = GetNewestFolder(SRC_FOLDER)
  '「完了」フォルダ下の社名フォルダリスト取得
  companies = GetCompanies(path & "\完了")
  '各社名フォルダ下のxlsxファイルをコピー
  For Each company In companies
    fName = Dir(CStr(company) & "\*.xlsx")
    Do While fName <> ""
      FileCopy company & "\" & fName, BACKUP_FOLDER & "\" & fName
      fName = Dir()
    Loop
  Next
End Sub

'会社フォルダ名リストを取得する
Private Function GetCompanies(path As String) As Variant
  Dim fName As String
  Dim companies As Variant
  companies = Array()
  
  fName = Dir(path & "\*", vbDirectory)
  Do While fName <> ""
    If fName <> ".." And fName <> "." Then
      ReDim Preserve companies(UBound(companies) + 1)
      companies(UBound(companies)) = path & "\" & fName
    End If
    fName = Dir()
  Loop
  GetCompanies = companies
End Function

'最新処理日時フォルダ名取得
Private Function GetNewestFolder(path As String) As String
  Dim fName As String
  Dim dateTime As Long
  Dim dateTimeName As String
  Dim dt As String
  dateTime = 0
  dateTimeName = ""
  
  fName = Dir(path & "\????_????", vbDirectory)
  Do While fName <> ""
    dt = Replace(fName, "_", "")
    If IsNumeric(dt) And dateTime < CLng(dt) Then
      dateTime = CLng(dt)
      dateTimeName = fName
    End If
    fName = Dir()
  Loop
  GetNewestFolder = path & "\" & dateTimeName
End Function
-----ここまで
    • good
    • 0
この回答へのお礼

すごい!やりたいことが、ばっちりできました。
会社フォルダ名の取得の仕方など、大変参考になります。
なお、最新処理日時フォルダ名取得は、フォルダのプロパティの作成日から判断するようにしてみました。
(困ったことに、無断でフォルダ名を変えてしまう輩がいるもので、(苦)
本当に有難うございました!とても助かります。

Private Function GetNewestFolder(path As String) As String
Dim sFlder As Variant
Dim NsFlder As Variant

Set FSO = CreateObject("Scripting.FileSystemObject")
For Each sFlder In FSO.GetFolder(SRC_FOLDER).SubFolders
If NsFlder = "" Then
NsFlder = sFlder
Else
If FSO.GetFolder(NsFlder).DateCreated < FSO.GetFolder(sFlder).DateCreated Then
NsFlder = sFlder
End If
End If
Next
GetNewestFolder = NsFlder

End Function

お礼日時:2018/08/05 06:47

疑問なのですが



1.VBAでの実現が必須なのでしょうか?
こういうのはバッチファイル等で作成してダブルクリックで実行するほうが手軽だと思います。

2.バックアップフォルダ以下のフォルダ構成は?
  ・元の構成を維持?
  ・バックアップフォルダ直下にファイルのみを一律に並べる?
  ・その他
この回答への補足あり
    • good
    • 0

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

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

Q線をアレンジしたい。

描画に挑戦し、色々教えていただいていますが、
まだまだ遅々として進んでいません。

以下のコードを頂きました。
→半径が100で中心(200,200)から放射状に線が引けます。

コレを時計の文字盤の様なイメージ※に変更したいのですが、
どうにも手が出せずにいます。
ドウ手を入れれば宜しいでしょうか。

※文字盤のようなイメージ
 →線が中心からではなく、
  円周の少し中側から円周に向かって引けている様なイメージ

宜しくお願いします。

Sub en09()
Dim pai As Single
Dim x As Single
Dim y As Single
Dim n As Long
pai = 3.1415926535
For n = 0 To 360 Step 6
x = 100 * Cos(n * pai / 180)
y = 100 * Sin(n * pai / 180)
ActiveSheet.Shapes.AddLine 200, 200, x + 200, -y + 200
Next
End Sub

描画に挑戦し、色々教えていただいていますが、
まだまだ遅々として進んでいません。

以下のコードを頂きました。
→半径が100で中心(200,200)から放射状に線が引けます。

コレを時計の文字盤の様なイメージ※に変更したいのですが、
どうにも手が出せずにいます。
ドウ手を入れれば宜しいでしょうか。

※文字盤のようなイメージ
 →線が中心からではなく、
  円周の少し中側から円周に向かって引けている様なイメージ

宜しくお願いします。

Sub en09()
Dim pai As Single
Dim x As Sin...続きを読む

Aベストアンサー

一案です。

以下のプログラムをForループの中の li = GetShrinkLine(li, 0.9) を無くした状態とで比較してみて下さい。

・過去のご質問の内容も網羅しています。
・座標情報および線分情報は、Point、LineInfoというユーザ定義型で管理しています。
・描画した線情報は配列Linesに保管するので、後で特定の線を削除できます。
・始点から任意の角度で引いたの線情報の取得および描画を関数GetLineInfoRPで行っています。
・始点から特定の割合で線を消した線情報の取得を関数GetShrinkLineで行っています。

※2つの関数の中身を理解する必要はありません、使い方だけ理解できればOKです。


----ここから
'座標を保持するユーザー定義型
Public Type Point
  x As Long
  y As Long
End Type

'線情報を保持するユーザー定義型
Public Type LineInfo
  shtName As String '描画シート
  sPoint As Point '始点座標
  ePoint As Point '終点座標
  lineName As String '線の名前
  length As Double '長さ
  angle As Long  '角度
  isAlive As Boolean 'シート上に存在するか否か
End Type


'
Sub Sample()
  Dim angle As Long
  Dim sp As Point
  Dim lines() As LineInfo
  Dim li As LineInfo
  
  ReDim lines(0)
  '始点
  sp.x = 200
  sp.y = 200
  '6°おきに放射状に長さ100の線を描く
  For angle = 0 To 359 Step 6
    '放射状の線情報取得(情報として、描くシート、始点、長さ、角度、描画しない、を与えている)
    li = GetLineInfoRP(ActiveSheet, sp, 100, angle, False)
    '始点から90%を消した線情報を取得
    li = GetShrinkLine(li, 0.9)
    '描画し、その線情報を取得(情報として、描くシート、始点、長さ、角度、描画する(省略)、を与えている)
    li = GetLineInfoRP(ActiveSheet, li.sPoint, li.length, li.angle)

    '線情報を配列に追加
    lines(UBound(lines)) = li
    ReDim Preserve lines(UBound(lines) + 1)
  Next
     
'  '2番目(要素番号1)の線をシートから削除
'  If lines(1).isAlive Then
'    Worksheets(lines(1).shtName).Shapes(lines(1).lineName).Delete
'    lines(1).isAlive = False
'  End If

End Sub


'線の各情報(シート名、始点、長さ、角度, 描画有無)を渡し、線情報を返す関数
Function GetLineInfoRP(sh As Worksheet, s As Point, length As Double, angle As Long, Optional draw As Boolean = True) As LineInfo
  Dim e As Point
  Dim li As LineInfo
  
  e.x = s.x + length * Cos(WorksheetFunction.Radians(angle))
  e.y = s.y - length * Sin(WorksheetFunction.Radians(angle))
  If draw Then
    sh.Shapes.AddLine s.x, s.y, e.x, e.y '描画
    li.lineName = sh.Shapes(sh.Shapes.Count).name '線の名前を取得
    li.isAlive = True
  Else
    li.lineName = "None"
    li.isAlive = False
  End If
  li.shtName = sh.name
  li.sPoint.x = s.x
  li.sPoint.y = s.y
  li.ePoint.x = e.x
  li.ePoint.y = e.y
  li.length = length
  li.angle = angle
  GetLineInfoRP = li
End Function



'与えられた線情報の始点からrateだけ消した線情報を返す関数
Function GetShrinkLine(src As LineInfo, rate As Double) As LineInfo
  Dim r As LineInfo

  r.shtName = src.shtName
  r.length = src.length * (1 - rate)
  r.angle = src.angle
  r.ePoint = src.ePoint
  r.sPoint.x = src.sPoint.x + (src.ePoint.x - src.sPoint.x) * rate
  r.sPoint.y = src.sPoint.y + (src.ePoint.y - src.sPoint.y) * rate
  r.lineName = "None"
  r.isAlive = False
  GetShrinkLine = r
End Function
----ここまで

一案です。

以下のプログラムをForループの中の li = GetShrinkLine(li, 0.9) を無くした状態とで比較してみて下さい。

・過去のご質問の内容も網羅しています。
・座標情報および線分情報は、Point、LineInfoというユーザ定義型で管理しています。
・描画した線情報は配列Linesに保管するので、後で特定の線を削除できます。
・始点から任意の角度で引いたの線情報の取得および描画を関数GetLineInfoRPで行っています。
・始点から特定の割合で線を消した線情報の取得を関数GetShrinkLineで行っています。

※...続きを読む


人気Q&Aランキング