Excel (VBA)

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

 
(Windows 10 Pro : Excel 2010)
xlsm形式のファイルからxlsx形式で保存(ファイル名はセル値)するには
投稿日時: 20/06/09 19:59:38
投稿者: もぐもぐ風林火山

すいません、全然知識が追い付かず、とんちんかんな事を言っていたらすいません。
 
やりたいこととしては…
1.ファイルを開く
2.ボタン押下
3.そのファイル内のシート(シート名:納品)をxlsx形式で別ファイルとして所定フォルダに保存
4.保存ファイル名は2つのセルの値を合わせてファイル名とする
です。
 
作りかけですが、ファイル格納場所やファイル名が変で止まっています。
 
 
Private Sub CommandButton1_Click()
 
 
Dim hozon As String 'ドライブ等のパス用
Dim FolName As String 'A1セル用のフォルダ名用
Dim FilName As String 'A2セル用のファイル名用
Dim FilName1 As String '
 
 
Set wb = ThisWorkbook
 
Set ws = ActiveSheet
 
 
  hozon = "C:\Users\mytest\Desktop\卸値\結果"
'A1セルの値
  FolName = ws.Range("I2").Value
'A2セルの値をファイル名
  FilName1 = ws.Range("K5").Value
 
 
 Sheets("納品").Copy '名前を付け、ファイル形式も決めて特定の場所に保存する。
 ActiveWorkbook.SaveAs Filename:=hozon & FolName & Filename1, FileFormat:=xlOpenXMLWorkbook
 
End Sub
 
申し訳ございませんが、ご助力お願いできますでしょうか。
言葉足らずの場合は修正いたします。
 
どうぞよろしくお願いします。

回答
投稿日時: 20/06/09 20:20:40
投稿者: mndkyui

 
 Sheets("納品").Copy '名前を付け、ファイル形式も決めて特定の場所に保存する。
 〉〉ActiveWorkbook.SaveAs Filename:=hozon & FolName & Filename1, FileFormat:=xlOpenXMLWorkbook
 
 
単純にhozonとFolNameの間に''\''が必要ですね。
hozonが固定でしたら\を1番後につけたらいいかと思います。

回答
投稿日時: 20/06/09 20:57:24
投稿者: takesi

対象シートを新規bookにコピーして、マクロなし(xlsx)ファイルとして保存する。
 

 Option Explicit
Sub CommandButton1_Click()
    Dim svPath As String
    Dim Wb As Workbook, Ws  As Worksheet
    Dim trgWb As Workbook, trgWs As Worksheet
    Dim shNo As Long, i As Long
    Dim strFname As Variant
    
    strFname = Array("I2", "K5")      'ファイル名に添付する文字列
    Set Wb = ThisWorkbook             'このプログラムを実行しているBook
    Set Ws = Wb.ActiveSheet           '保存ファイル名のあるシート
    Set trgWs = Wb.Worksheets("納品") 'コピー対象シート
    
    '保存用新規Book
    Workbooks.Add              '新規ブック作成
    Set trgWb = ActiveWorkbook   '新規ブック
    '対象シートをtrgWbの最初のタブ位置にコピー
    trgWs.Copy Before:=trgWb.Sheets(1)
    ' trgWbの二つ目以降のシート削除
    If trgWb.Sheets.Count > 1 Then
      For shNo = trgWb.Sheets.Count To 2 Step -1
        '削除確認メッセージを非表示で実行
        Application.DisplayAlerts = False
        trgWb.Sheets(shNo).Delete
        Application.DisplayAlerts = True
       Next
    End If
    
    '保存
    svPath = Wb.Path & "\"      'このBookのパス
    For i = 0 To UBound(strFname)
      svPath = svPath & Ws.Range(strFname(i)).Text
    Next
    'マクロ確認メッセージを非表示で実行
    Application.DisplayAlerts = False
      trgWb.SaveAs Filename:=svPath, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    trgWb.Close
     
    Set trgWs = Nothing
    Set trgWb = Nothing
    Set Ws = Nothing
    Set Wb = Nothing
End Sub

投稿日時: 20/06/10 09:27:46
投稿者: もぐもぐ風林火山

mndkyuiさん
 
 
アドバイス、ありがとうございます。
後学のために、ご教授いただいたコードを取り込んでテストしてみます。
 
 

投稿日時: 20/06/10 10:18:07
投稿者: もぐもぐ風林火山

takesiさん
 
コード、ありがとうございます。
 
もう1点、教えてください。ローカルウィンドウ?で1行ずつ追っていますが
どうしても分からない箇所が。
 
仕様追加要望で
1.ファイル名を1つセルを追加(セルO5)
2.保存先をもう1つ深い階層にする
 
という話があり、コードを下記のように変更してみましたが、
思った動きがしません。
 
1について
strFname = Array("I2", "K5") 'ファイル名に添付する文字列

strFname = Array("O5","I2", "K5")としてみました。
ただし、下記場所で1行ずつ実行してもI2,K5のファイル名しか付与されません。。
 '保存
    svPath = Wb.Path & "\"      'このBookのパス
    For i = 0 To UBound(strFname)
      svPath = svPath & Ws.Range(strFname(i)).Text
    Next
 
ん〜まだまだ理解不足です。すいません。
 
2について
'保存
    svPath = Wb.Path & "\"      'このBookのパス
    For i = 0 To UBound(strFname)
      svPath = svPath & Ws.Range(strFname(i)).Text
    Next
ここのBookパスを
    svPath = Wb.Path & "\" & "納入" &     'このBookのパス
と思ったのですが…違うようでした。
 
この2点、再度ご教授いただけますでしょうか。
 
申し訳ございませんが、よろしくお願いします。

回答
投稿日時: 20/06/11 10:00:14
投稿者: takesi

二回保存するのであれば、新規book作成、保存部分を分離して、二回呼び出すのがよいと思います。
 
今回のは、保存ホルダー、ファイル名がセル値で汎用性があると思いますが"納入"は、セルに納めないのでしょうか?
単純な方法として、ホルダーを納めるセルに "納入" を結合しておくとか?
 

回答
投稿日時: 20/06/11 10:00:20
投稿者: takesi

二回保存するのであれば、新規book作成、保存部分を分離して、二回呼び出すのがよいと思います。
 
今回のは、保存ホルダー、ファイル名がセル値で汎用性があると思いますが"納入"は、セルに納めないのでしょうか?
単純な方法として、ホルダーを納めるセルに "納入" を結合しておくとか?
 

回答
投稿日時: 20/06/11 10:06:20
投稿者: takesi

書き忘れました
 
後、ファイルパスの"\"がセル値にあるのか、
プログラムで処理するのか、どちらになるのでしょうか?

回答
投稿日時: 20/06/11 18:01:37
投稿者: takesi

勘違いしていました、上記2件の書込み破棄してください。
 

 Option Explicit
Sub CommandButton1_Click()
    Dim svPath As String
    Dim Wb As Workbook, Ws  As Worksheet
    Dim trgWb As Workbook, trgWs As Worksheet
    Dim shNo As Long, i As Long
    Dim strFname As Variant
    
    strFname = Array("O5", "I2", "K5")     'ファイル名に添付する文字列
    Set Wb = ThisWorkbook             'このプログラムを実行しているBook
    Set Ws = Wb.ActiveSheet           '保存ファイル名のあるシート
    Set trgWs = Wb.Worksheets("納品") 'コピー対象シート
    
    '保存用新規Book
    Workbooks.Add              '新規ブック作成
    Set trgWb = ActiveWorkbook   '新規ブック
    '対象シートをtrgWbの最初のタブ位置にコピー
    trgWs.Copy Before:=trgWb.Sheets(1)
    ' trgWbの二つ目以降のシート削除
    If trgWb.Sheets.Count > 1 Then
      For shNo = trgWb.Sheets.Count To 2 Step -1
        '削除確認メッセージを非表示で実行
        Application.DisplayAlerts = False
        trgWb.Sheets(shNo).Delete
        Application.DisplayAlerts = True
       Next
    End If
    
    '保存
    svPath = Wb.Path & "\" & "納入" & "\"           'このBookのパス+階層
    '保存先ディレクトリーの確認
    If Dir(svPath, vbDirectory) = "" Then
      MkDir svPath  'なければ新規作成
    End If
    '
    For i = 0 To UBound(strFname)
      svPath = svPath & Ws.Range(strFname(i)).Text
    Next
    'マクロ確認メッセージを非表示で実行
    Application.DisplayAlerts = False
      trgWb.SaveAs Filename:=svPath, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    trgWb.Close
     
    Set trgWs = Nothing
    Set trgWb = Nothing
    Set Ws = Nothing
    Set Wb = Nothing
End Sub

投稿日時: 20/06/12 12:31:02
投稿者: もぐもぐ風林火山

takesiさん
 
 いつもありがとうございます。
 
おかげで試行し、思うような動きになりました。
コードを見て、1行ずつ実行することで、動きの流れは理解しつつありますが、
何もないところで「作れ」はまだまだできそうにありません。
 
今後もここを活用しつつ、勉強していきたいと思います。
 
本当に助かりました。またよろしくお願いいたします。