Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9386 / 13644 ツリー ←次へ | 前へ→

【27650】ブックの新規作成とコピー たかし 05/8/14(日) 22:09 質問[未読]
【27651】Re:ブックの新規作成とコピー ponpon 05/8/14(日) 23:41 発言[未読]
【27653】Re:ブックの新規作成とコピー Hirofumi 05/8/15(月) 3:12 回答[未読]
【27654】Re:ブックの新規作成とコピー たかし 05/8/15(月) 10:23 質問[未読]
【27656】Re:ブックの新規作成とコピー たかし 05/8/15(月) 10:34 質問[未読]
【27663】Re:ブックの新規作成とコピー Hirofumi 05/8/15(月) 12:43 回答[未読]
【27666】Re:ブックの新規作成とコピー たかし 05/8/15(月) 13:12 質問[未読]
【27667】Re:ブックの新規作成とコピー Hirofumi 05/8/15(月) 14:31 回答[未読]
【27669】Re:ブックの新規作成とコピー たかし 05/8/15(月) 15:03 お礼[未読]

【27650】ブックの新規作成とコピー
質問  たかし  - 05/8/14(日) 22:09 -

引用なし
パスワード
   お世話になってます。
今回は、ブックを新規に作成し、元のブックのシートをコピーするマクロを作成しました。
そこで、いくつか思うように動作しない箇所があります。
どなたかいいアドバイスをいただけないでしょうか?
過去ログからいろいろ調べて、ここまでは作成してみましたが、うまくいきません。
よろしくお願いします。

1. ユーザーフォーム上に、保存用のファイル名を決めるTextboxがあります。
2. コピーするシートを決定するためのCheckboxが4つあります。
3. 実行するためのCommandbuttonがあります。

問題1
Textbox1の内容が、名前をつけて保存のファイル名に反映する方法が分かりません。
いい方法があれば、教えてください。

問題2
どうも、コピーされていません。というか、元ファイルのファイル名が変更されているだけ
のような気がします。
どうすれば良いでしょうか?


マクロ
Private Sub CommandButton1_Click()
  Dim savPath As Variant
  Dim fName As String
  Dim a As Integer, b As Integer
 
 Workbooks.Add

 Application.DisplayAlerts = False

    savPath = Application.GetSaveAsFilename( _
          InitialFileName:="作業報告書.xls", _
              FileFilter:="Excelファイル (*.xls), *.xls,すべてのファイル(*.*),*.*")
    
    If savPath <> False Then
      fName = Dir(savPath)
   
      If fName <> "" Then
        a = MsgBox("同じ名前のファイルがあります。上書きしますか?", vbYesNoCancel)
        Select Case a
        Case 6 'OK
          ActiveWorkbook.SaveAs Filename:=savPath
          Unload Me
          Exit Sub
        Case 7 'NO
    
        Case 2 'Cancel
          Exit Sub
        End Select
      Else
        ActiveWorkbook.SaveAs Filename:=savPath
        Unload Me
        Exit Sub
      End If
    Else
      Exit Sub
    End If

 If CheckBox1 = ture Then
  Windows("作業報告書_保存.xls").Activate
  Sheets("データシート").Select
  Cells.Copy
  Windows("Book1").Activate
  Sheets("Sheet1").Select
  Sheets.Add.Name = "データシート"
  Cells.Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
  Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
  Range("A1").Select
 Else
  If CheckBox2 = ture Then

   以下、同様にCheckBox2、CheckBox3、CheckBox4でシート2・3・4をコピーする
  End If
 End If
End Sub

よろしくお願いします。

【27651】Re:ブックの新規作成とコピー
発言  ponpon  - 05/8/14(日) 23:41 -

引用なし
パスワード
   こんばんは。

できるだけ、提示のコードを生かすようにしました。
もっと良い方法があると思います。
試してください。

フォームモジュールに

Private Sub CommandButton1_Click()
   Dim myWB As Workbook
 
  Set myWB = Workbooks.Add
  If Me.CheckBox1.Value = True Then
    myWB.Sheets(1).Name = "データシート"
    Workbooks("作業報告書_保存.xls").Sheets("データシート").Cells.Copy _
                myWB.Sheets("データシート").Range("A1")
    Call 保存
  
  ElseIf Me.CheckBox2.Value = True Then
  

'   以下、同様にCheckBox2、CheckBox3、CheckBox4でシート2・3・4をコピーする
  End If
End Sub


標準モジュールに
Sub 保存()
  Dim savPath As Variant
  Dim fName As String
  Dim a As Integer, b As Integer
 

  Application.DisplayAlerts = False

'    savPath = Application.GetSaveAsFilename( _
'          InitialFileName:="作業報告書.xls", _
'              FileFilter:="Excelファイル (*.xls), *.xls,すべてのファイル(*.*),*.*")
     If UserForm1.TextBox1.Text <> "" Then
      savPath = UserForm1.TextBox1.Text & ".xls"
       fName = Dir(ThisWorkbook.Path & savPath)
 
      If fName <> "" Then
        a = MsgBox("同じ名前のファイルがあります。上書きしますか?", vbYesNoCancel)
        Select Case a
        Case 6 'OK
          ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & savPath
          Unload UserForm1
          ActiveWorkbook.Close
          Exit Sub
          
        Case 7 'NO
  
        Case 2 'Cancel
          Exit Sub
        End Select
       Else
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & savPath
        Unload UserForm1
        ActiveWorkbook.Close
        Exit Sub
       End If
     Else
      MsgBox "ファイル名がありません。"
      UserForm1.TextBox1.SetFocus
      Exit Sub
      
     End If

End Sub

【27653】Re:ブックの新規作成とコピー
回答  Hirofumi  - 05/8/15(月) 3:12 -

引用なし
パスワード
   >  お世話になってます。
>今回は、ブックを新規に作成し、元のブックのシートをコピーするマクロを作成しました。
>そこで、いくつか思うように動作しない箇所があります。
>どなたかいいアドバイスをいただけないでしょうか?
>過去ログからいろいろ調べて、ここまでは作成してみましたが、うまくいきません。
>よろしくお願いします。
>
>1. ユーザーフォーム上に、保存用のファイル名を決めるTextboxがあります。
>2. コピーするシートを決定するためのCheckboxが4つあります。
>3. 実行するためのCommandbuttonがあります。
>
>問題1
>Textbox1の内容が、名前をつけて保存のファイル名に反映する方法が分かりません。
>いい方法があれば、教えてください。
>
>問題2
>どうも、コピーされていません。というか、元ファイルのファイル名が変更されているだけ
>のような気がします。
>どうすれば良いでしょうか?

尚、UserForm上には、もう一つCommandButton2を配し、此れをTextBox1の保存名変更用とします
以下をUserFormのコードモジュールに記述して下さい

Option Explicit

'CheckBoxの数
Const lngBoxCount As Long = 4

'CheckBoxで選択されるシート名
Private vntCopySheets As Variant
'FileSystemObjectの参照を保存
Private objFso As Object

Private Sub UserForm_Initialize()

  'CheckBoxで選択するSheet名を設定
  vntCopySheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
  
  'TextBox1に保存名の初期値を設定
  TextBox1.Text = ThisWorkbook.Path & "\" & "作業報告書.xls"
  
  'FileSystemObjectを作成
  Set objFso = CreateObject("Scripting.FileSystemObject")

End Sub

Private Sub UserForm_Terminate()

  'FileSystemObjectを破棄
  Set objFso = Nothing
  
End Sub

Private Sub CommandButton1_Click()

  BookSave
'  Unload Me
  
End Sub

Private Sub CommandButton2_Click()

'  TextBox1の保存名変更

  Dim vntFileName As Variant
  Dim strPath As String
  
  vntFileName = TextBox1.Text
  '保存ダイアログを表示
  If GetWriteFile(vntFileName, strPath) Then
    TextBox1.Text = vntFileName
  End If
  
End Sub

Private Sub BookSave()

  Dim i As Long
  Dim vntFileName As Variant
  Dim strPath As String
  Dim wkbSave As Workbook
  Dim wkbFrom As Workbook
  Dim strProm As String
  
  vntFileName = TextBox1.Text
  If objFso.FileExists(vntFileName) Then
    strProm = "マクロの実行を中止します"
    Select Case MsgBox("同じ名前のファイルがあります。上書きしますか?", _
          vbYesNoCancel + vbInformation, "FileExists")
      Case vbNo
        '保存ダイアログを表示して、保存Book名を変更
        If GetWriteFile(vntFileName, strPath) Then
          TextBox1.Text = vntFileName
        Else
          If MsgBox("上書きしますか?", vbInformation _
                  + vbOKCancel, "上書") = vbCancel Then
            GoTo Wayout
          End If
        End If
      Case vbCancel
        GoTo Wayout
    End Select
  End If
  
  Application.ScreenUpdating = False
  
  'ActiveWorkbookの参照を取得
  Set wkbFrom = ActiveWorkbook
  
  'CheckBoxのシートを新規BookにCopy
  For i = 1 To lngBoxCount
    If Controls("CheckBox" & i) Then
      If wkbSave Is Nothing Then
        wkbFrom.Worksheets(vntCopySheets(i - 1)).Copy
        Set wkbSave = ActiveWorkbook
      Else
        With wkbSave
          wkbFrom.Worksheets(vntCopySheets(i - 1)).Copy _
              After:=wkbSave.Worksheets(.Worksheets.Count)
        End With
      End If
    End If
  Next i
  
  '新規Bookを名前を付けて保存
  If wkbSave Is Nothing Then
    strProm = "シートの選択が無いのでBookが作成されませんでした"
  Else
    Application.DisplayAlerts = False
    With wkbSave
      .SaveAs FileName:=vntFileName
      .Close
    End With
    Application.DisplayAlerts = True
    strProm = "処理が完了しました"
  End If
  
Wayout:
  
  Application.ScreenUpdating = False
  
  Set wkbSave = Nothing
  Set wkbFrom = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "Excel Book (*.xls),*.xls"
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  '「ファイルを保存」ダイアログを表示
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 1)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function

【27654】Re:ブックの新規作成とコピー
質問  たかし  - 05/8/15(月) 10:23 -

引用なし
パスワード
   ponponさん、hirofumiさんありがとうございました。
今回は、hirofumiさんを参考にして作成しました。
しかし、エラーが発生してしまいます。
エラー内容
 実行時エラー'9';
  インデックスが有効にありません。
デバックすると、
 wkbFrom.Worksheets(vntCopySheets(i - 1)).Copy
の部分が黄色で表示されます。

どうすれば良いでしょうか?

【27656】Re:ブックの新規作成とコピー
質問  たかし  - 05/8/15(月) 10:34 -

引用なし
パスワード
   すみませんでした。
シートの名前を変更し、正常に終了しました。

そこで、新たな質問ですが、マクロをすべて削除した状態でコピー
できないでしょうか?

よろしくお願いします。


▼たかし さん:
>ponponさん、hirofumiさんありがとうございました。
>今回は、hirofumiさんを参考にして作成しました。
>しかし、エラーが発生してしまいます。
>エラー内容
> 実行時エラー'9';
>  インデックスが有効にありません。
>デバックすると、
> wkbFrom.Worksheets(vntCopySheets(i - 1)).Copy
>の部分が黄色で表示されます。
>
>どうすれば良いでしょうか?

【27663】Re:ブックの新規作成とコピー
回答  Hirofumi  - 05/8/15(月) 12:43 -

引用なし
パスワード
   >そこで、新たな質問ですが、マクロをすべて削除した状態でコピー
>できないでしょうか?

選択されたシート(Copyされるシート)に、マクロが書いて有るのですか?
このコードでは、選択されたシートを新規BookにCopyし、そのBookをSaveする方法を取っています
因って、選択されたシート(Copyされるシート)のコードモジュールにマクロが書いてあれば
其のまま、Copyされると思います(逆に、シートにマクロが無ければ問題ないのでは?)
もし、そうだとするとこのコードでは、出来ません
大幅にコードを変更する必要が有りますが?

【27666】Re:ブックの新規作成とコピー
質問  たかし  - 05/8/15(月) 13:12 -

引用なし
パスワード
   シートにマクロがあります。
保存用のユーザーフォームを表示するためのCommandbuttonとマクロがあります。
すべてのマクロを削除するコマンドとかは、ないですかね?
できれば、Commandbuttonも削除したいです。
新たにマクロ用のシートを追加するしかないでしょうか?

また、セルの数式等は必要ではなく、値と書式のみのコピーにしたいのですが、
これも大幅な変更になってしまいますよね?

申し訳ありませんが、ご教授願えませんでしょうか?
よろしくお願いします。

【27667】Re:ブックの新規作成とコピー
回答  Hirofumi  - 05/8/15(月) 14:31 -

引用なし
パスワード
   あんまりコードが気に入らないんだけど?
こんなかな?

「Sub BookSave」だけが、変更に成りますので入換えて下さい

Private Sub BookSave()

  Dim i As Long
  Dim vntFileName As Variant
  Dim strPath As String
  Dim wkbSave As Workbook
  Dim wkbFrom As Workbook
  Dim strProm As String
  Dim lngCount As Long
  
  vntFileName = TextBox1.Text
  If objFso.FileExists(vntFileName) Then
    strProm = "マクロの実行を中止します"
    Select Case MsgBox("同じ名前のファイルがあります。上書きしますか?", _
          vbYesNoCancel + vbInformation, "FileExists")
      Case vbNo
        '保存ダイアログを表示して、保存Book名を変更
        If GetWriteFile(vntFileName, strPath) Then
          TextBox1.Text = vntFileName
        Else
          If MsgBox("上書きしますか?", vbInformation _
                  + vbOKCancel, "上書") = vbCancel Then
            GoTo Wayout
          End If
        End If
      Case vbCancel
        GoTo Wayout
    End Select
  End If
  
  Application.ScreenUpdating = False
  
  'ActiveWorkbookの参照を取得
  Set wkbFrom = ActiveWorkbook
  
  'CheckBoxのTrueの数(シート数)を取得
  For i = 1 To lngBoxCount
    If Controls("CheckBox" & i) Then
      lngCount = lngCount + 1
    End If
  Next i
  'Copyするシートが有るなら
  If lngCount > 0 Then
    '新規Bookを追加
    Set wkbSave = Workbooks.Add
    '新規Bookのシート数が必要数以下ならシートを追加
    With wkbSave.Worksheets
      If .Count < lngCount Then
        .Add After:=.Item(.Count), Count:=lngCount - .Count
      End If
    End With
  End If
  'CheckBoxのシートを新規BookにCopy
  lngCount = 0
  With wkbSave
    For i = 1 To lngBoxCount
      If Controls("CheckBox" & i) Then
        lngCount = lngCount + 1
        wkbFrom.Worksheets(vntCopySheets(i - 1)).UsedRange.Copy
        With .Worksheets(lngCount)
          .Cells(1, "A").PasteSpecial _
              Paste:=xlFormats, Operation:=xlNone, _
              SkipBlanks:=False, Transpose:=False
          .Cells(1, "A").PasteSpecial _
              Paste:=xlValues, Operation:=xlNone, _
              SkipBlanks:=False, Transpose:=False
          Application.CutCopyMode = False
          .Activate
          .Cells(1, "A").Select
          On Error Resume Next
          .Name = vntCopySheets(i - 1)
          On Error GoTo 0
        End With
      End If
    Next i
  End With
  
  '新規Bookを名前を付けて保存
  If wkbSave Is Nothing Then
    strProm = "シートの選択が無いのでBookが作成されませんでした"
  Else
    Application.DisplayAlerts = False
    With wkbSave
      .SaveAs FileName:=vntFileName
      .Close
    End With
    Application.DisplayAlerts = True
    strProm = "処理が完了しました"
  End If
  
Wayout:
  
  Application.ScreenUpdating = False
  
  Set wkbSave = Nothing
  Set wkbFrom = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

【27669】Re:ブックの新規作成とコピー
お礼  たかし  - 05/8/15(月) 15:03 -

引用なし
パスワード
   ▼Hirofumi さん:
ありがとうございました。
本当に助かりました。

若干私なりに修正しました。
コピーする順番がFormats⇒Valusでは、セルの結合が邪魔で、
エラーが出てしまったので、順番を逆にしました。
また、コピー元でのコピー方法を、UseRangeからCellsに変えて
コピーしたら、セルの幅や高さもコピーすることができました。

これを参考に、自分で解読、勉強しようと思います。

長いマクロを組んでいただいて、本当にありがとうございました。

9386 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free