Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
既存のファイルがあった場合、シートを追加したい
投稿日時: 20/01/20 16:26:18
投稿者: TANPOPO

下記コードを使って、ファイル名を当日にして指定したフォルダに保存しています。
 

  Sub macro1()
  
    filepass = "C:\Users\aaa\Desktop\フォルダ"

Filename = Format(Now, "yymmdd")
ActiveWorkbook.SaveAs filepass & "\" & "週初レポート_" & Filename & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

  End Sub

 
既存のファイルがあった場合、上書きではなく、シートを追加したいのですが、どのような方法がありますでしょうか。
 
ご教授いただければ幸いです。
宜しくお願い致します。

回答
投稿日時: 20/01/20 17:26:12
投稿者: WinArrow
投稿者のウェブサイトに移動

指定ファイルの存在有無チェック
DIR関数を使います。
 IF DIR(ファイルフルパス) <> "" Then
   ファイルあり
 

回答
投稿日時: 20/01/21 09:39:18
投稿者: WinArrow
投稿者のウェブサイトに移動

引用:
既存のファイルがあった場合、上書きではなく、シートを追加したいのですが、どのような方法がありますでしょうか。

 
方法論からいいますと
 
まず、これから作成しようとするファイル(フルパス)で存在確認をします。
 →前レスのDIR関数を参照
 
次に、ファイルが存在した場合は、
当該ファイル(ブック)を開き→シート追加→ブックの上書き保存→当該ファイルを閉じる
という手順になります。
※シーと追加時には同名のシートの存在有無確認も必要でしょう。
 
ファイルが存在しなかった場合は、
掲示のコードでよいと思います。

投稿日時: 20/01/21 13:19:00
投稿者: TANPOPO

WinArrowさん
 
ありがとうございます。
 
DIR関数を用いて作成してみます。
取り急ぎお礼まで。。

投稿日時: 20/01/21 14:08:37
投稿者: TANPOPO

WinArrowさん
 
教えていただいた

引用:
次に、ファイルが存在した場合は、 当該ファイル(ブック)を開き→

を実施しようとしたのですが、
下記コードでは開くことができませんでした。
  Sub macro1()
  
  
    Windows("テスト.xlsm").Activate
    filepass = "ファイルフルパス"
  
     If Dir("ファイルフルパス") <> "" Then
   
    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy
  
   
Filename = Format(Now, "yymmdd")
ActiveWorkbook.SaveAs filepass & "\" & "123_" & Filename & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   
   
   End If
       Sheets("Sheet1").Select
    Sheets("Sheet1").Copy
   
    Workbooks.Open Filename:=filepass & "\" & "123_" & Filename & ".xlsx"
   Windows("テスト.xlsm").Activate
    Sheets("Sheet1").Select
    
    
   End Sub

 
 
 
恐れ入りますが、
    Workbooks.Open Filename:=filepass & "\" & "123_" & Filename & ".xlsx"
の書き方をご教授いただければ幸いです。
よろしくお願いします。

回答
投稿日時: 20/01/21 14:17:56
投稿者: mattuwan44

Option Explicit

Sub メイン()
    Const strFolderPath As String = "C:\Users\aaa\Desktop\フォルダ"
    Dim dtmToday As Date
    Dim dtmBeginning As Date
    Dim wbk As Workbook
    Dim blnNew As Boolean
    dtmToday = Date
    dtmBeginning = dtmToday - Weekday(dtmToday) + 1

    '保存するブックの取得
    Set blnNew = orgFileExists(strFolderPath, dtmBeginning, wbk)

    'シートのコピー
    orgCopySheet dtmToday, ActiveSheet, wbk, blnNew
    
    'ブックの保存
    wbk.Save
End Sub

'保存するブックの取得
Function orgFileExists(ByVal sPath As String, _
                       ByVal dtmName As Date, _
                       ByRef wbkResult As Workbook) As Boolean
    Dim sFullPath As String
    '保存したいファイルのフルパス生成
    sFullPath = sPath & Format(sName, "YYMMDD") & ".xlsx"
    'ファイルの存在確認
    If Len(Dir(sFullPath)) > 0 Then
        'あったら開く
        Set wbkResult = Workbooks.Open(sFullPath)
        orgFileExists = True
    Else
        '無かったら新規で追加
        Set wbkResult = Workbooks.Add
        wbkResult.SaveAs sFullPath
    End If
End Function

'シートのコピー
Sub orgCopySheet(ByVal dtmDate As Date, _
                ByRef wsh As Worksheet, _
                ByRef wbk As Workbook, _
                ByVal flg As Boolean)
    Dim wshLast As Worksheet
    
    '一番右のシートを取得
    Set wshLast = wbk.Worksheets(wbk.Worksheets.Count)
    '指定されたシートを保存するシートの最後にコピー
    wsh.Copy After:=wshLast
    'シート名を変える
    wshLast.Next.Name = Format(dtmDate, "YYMMDD")
    '新規ブックの場合最初のシートを削除
    If flg = False Then wshLast.Delete
End Sub


 
こんな感じの流れではないでしょうか?
時間なくて焦って書いたので、間違っている箇所があるかも知れませんm【__】m

回答
投稿日時: 20/01/21 20:51:05
投稿者: WinArrow
投稿者のウェブサイトに移動

質問に掲示したコードは貴方が作成したものしょうか?
    
若し、他人が作成したコードの一部分を変更するのでしたら、
    
ご自分のレベルを説明していただくよう、お願いします。
    
「フルパス」とは、ドライブから始まってフォルダの階層〜最後のファイルまでを言います。
 「ファイルパス」なんてフォルダもファイルも、存在しません。
    
貴方が掲示したコードでいえば
filepass & "\" & "週初レポート_" & Filename & ".xlsx"
これがフルパスです。
    
それから、
mattuwan44 さんより、レスがありますので、私の方からはコメントしませんが、
コードをキチンと勉強するようお勧めします。

回答
投稿日時: 20/01/22 11:08:48
投稿者: WinArrow
投稿者のウェブサイトに移動

コメントしないつもりでしたが、気になったもので・・・
 
僭越ながら、mattuwan44 さんのレスのコードの問題点
 
> '保存するブックの取得
> Set blnNew = orgFileExists(strFolderPath, dtmBeginning, wbk)
 
慌てているのでしょうか?
コメントとコードが一致していない(Set は無理)
 
 
質問者さんへ
 
現在のマクロブックと、コードの中にあるActiveWorkbookはおなじでしょうか?
複数のブックを取り扱う場合、
マクロブックとデータブックを分けて作成(管理)した方が、よいと思います。
 
また、マクロブックは自分以外のPCで使用する前提ならば、
>"C:\Users\aaa\Desktop\フォルダ
の中の「aaa」部分がPCにょって異なるので、その対応を考える必要があります。
 
ファイルを保存するパスが、最初のコードと異なっているようですが、
変わったのでしょうか?
 
 

回答
投稿日時: 20/01/23 07:21:34
投稿者: simple

横からすみません。
 
もう少しエレメンタリーなものも提示しておきます。参考にしてください。
 

Sub macro1()
    Dim foldername   As String
    Dim filename     As String
    Dim fullpathname As String

    Dim ws As Worksheet
    Dim wb As Workbook

    foldername = "フォルダ名"       ' ■手入れのこと
    filename = Format(Now, "yymmdd")
    fullpathname = foldername & "\" & "123_" & filename & ".xlsx"

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    If Dir(fullpathname) = "" Then   '既存のファイルがない場合。1シートのブックを作成
        ws.Copy
        ActiveWorkbook.SaveAs fullpathname, _
                              FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    Else        ' 既存のファイルがある場合。そのファイルにシートを追加して保存。
        Set wb = Workbooks.Open(fullpathname)
        ws.Copy After:=wb.Worksheets(wb.Worksheets.count)   '最後に追加。
        wb.Save
        wb.Close SaveChanges:=False
    End If
End Sub

投稿日時: 20/01/24 10:47:42
投稿者: TANPOPO

WinArrowさん
ご指摘通り、初心者です。質問がとんちんかんで申し訳ありません。
おっしゃるとおりコードの勉強キチンとしないといけません。
 
マクロブックとデータブックを分けて管理したいと考えております。
ファイルを保存するパスが、最初のコードと異なっているのは、
編集しているうちに間違ってしまったからです。申し訳ありません。
 
色々お考えいただきありがとうございました。
 
 
 
mattuwan44さん
 
コードの提示ありがとうございました。
使ってみたものの、「オブジェクトが必要」のエラーが出てしまい、
私ではどうすることもできませんでした。
せっかく教えていただいたのに、活かすことができず申し訳ありません。
 
 
simpleさん
 
コードの提示ありがとうございました。
いただいたコードでやりたいことに近づいてきました。
 
シートが複数ある場合の設定方法を考えています。
Set ws = ThisWorkbook.Worksheets("Sheet1")
だとSheet1のみ対応になるかと思うのですが、
複数のシート、たとえば左から2番目と3番目と4番目のシートをコピーしたいという場合、
どのような方法がありますでしょうか。
もしよろしければご教授いただければ幸いです。

回答
投稿日時: 20/01/24 12:14:45
投稿者: simple

ああ、その動作をマクロ記録すればヒントが得られますよ。

投稿日時: 20/01/31 17:13:05
投稿者: TANPOPO

simpleさん、ありがとうございました。
長く開けっ放しで申し訳ありません。
作成できました。
 
Sub Macro1()
    Dim foldername As String
    Dim filename As String
    Dim fullpathname As String
 
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim wb As Workbook
 
    foldername = "\\\\\\\\\\\"
    filename = Format(Now, "yymmdd")
    fullpathname = foldername & "\" & "週初レポート_" & filename & ".xlsx"
 
    Set ws1 = ThisWorkbook.Worksheets(2)
    Set ws2 = ThisWorkbook.Worksheets(3)
    Set ws3 = ThisWorkbook.Worksheets(4)
 
    If Dir(fullpathname) = "" Then '既存のファイルがない場合。1シートのブックを作成
          Sheets.Add After:=ActiveSheet
        ActiveSheet.Move
        ActiveSheet.Name = "kesu"
        ActiveWorkbook.SaveAs fullpathname, _
                              FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                            wb.Save
        wb.Close SaveChanges:=False
         
         
    Else ' 既存のファイルがある場合。そのファイルにシートを追加して保存。
        Set wb = Workbooks.Open(fullpathname)
        ws1.Copy After:=wb.Worksheets(wb.Worksheets.Count) '最後に追加。
                ws2.Copy After:=wb.Worksheets(wb.Worksheets.Count) '最後に追加。
                        ws3.Copy After:=wb.Worksheets(wb.Worksheets.Count) '最後に追加。
    Dim ws As Worksheet
 
    For Each ws In Worksheets
      If ws.Name = "kesu" Then
    Application.DisplayAlerts = False
    ws.Delete
    Set ws = Nothing
 
      End If
    Next ws
             
         
        wb.Save
        wb.Close SaveChanges:=False
    End If
     
End Sub