Excel VBA質問箱 IV

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

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


8881 / 13646 ツリー ←次へ | 前へ→

【30551】ファイル選択をキャンセルした際の抜け方 kino 05/10/30(日) 18:28 質問[未読]
【30552】Re:ファイル選択をキャンセルした際の抜け方 Kein 05/10/30(日) 19:19 回答[未読]
【30553】Re:ファイル選択をキャンセルした際の抜け方 Kein 05/10/30(日) 19:20 発言[未読]
【30555】Re:ファイル選択をキャンセルした際の抜け方 kino 05/10/30(日) 21:04 質問[未読]
【30556】Re:ファイル選択をキャンセルした際の抜け方 かみちゃん 05/10/30(日) 21:13 発言[未読]
【30568】Re:ファイル選択をキャンセルした際の抜け方 kino 05/10/31(月) 2:25 お礼[未読]
【30559】Re:ファイル選択をキャンセルした際の抜け方 Kein 05/10/30(日) 21:38 発言[未読]

【30551】ファイル選択をキャンセルした際の抜け方
質問  kino  - 05/10/30(日) 18:28 -

引用なし
パスワード
   「コマンドボタンクリックで、エクセルファイル(複数の場合があります)を選択して開き取得した値を、
新規別ブックで保存」という動作をさせたいです。
エクセルファイル選択キャンセルした際の抜け方がわからないのと、
構文をもっと簡潔にする方法がありましたら ご指導お願いします。
(エクセルのバージョンは2000です)


Private Sub CommandButton1_Click()
  Dim FName As Variant
  Dim x As Variant
  Dim SourceName As String
  Dim a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s As Variant
  Dim t1, t2, t3, t4, t5, t6 As Variant
  
  FName = Application.GetOpenFilename( _
      FileFilter:="Excelファイル,*.xls,すべてのファイル,*.*", _
      MultiSelect:=True)

  i = 1
  For Each x In FName
    Workbooks.Open Filename:=x
    Worksheets(1).Activate
    a = Worksheets(1).Range("G1").Value
    b = Worksheets(1).Range("G2").Value
' c〜sまでデータを格納
    t1 = Worksheets(1).Range("a17:a30").Value
    t2 = Worksheets(1).Range("b17:b30").Value
    t3 = Worksheets(1).Range("j17:j30").Value
    t4 = Worksheets(1).Range("n17:n30").Value
    t5 = Worksheets(1).Range("p17:p30").Value
    t6 = Worksheets(1).Range("s17:s30").Value
    
    ActiveWorkbook.Close
    
    CreateNewBook

    Worksheets("Sheet1").Range("A6").Value = a
    Worksheets("Sheet1").Range("B6").Value = b
' c〜sの値を新しいシートのセルに格納
    Worksheets("Sheet1").Range("T6:t19").Value = t1
    Worksheets("Sheet1").Range("u6:u19").Value = t2
    Worksheets("Sheet1").Range("v6:v19").Value = t3
    Worksheets("Sheet1").Range("w6:w19").Value = t4
    Worksheets("Sheet1").Range("x6:x19").Value = t5
    Worksheets("Sheet1").Range("y6:y19").Value = t6
    
    i = i + 1
'ファイル名を付けて保存
    ActiveWorkbook.SaveAs Filename:=Format(Now, "yy-mm-dd hh-mm-ss") & CStr(i) & ".xls"
    ActiveWorkbook.Close
  Next x
   
End Sub

Sub CreateNewBook()
  Workbooks.Open "出力フォーム.xls"
  Worksheets("Sheet1").Activate
End Sub

【30552】Re:ファイル選択をキャンセルした際の抜...
回答  Kein  - 05/10/30(日) 19:19 -

引用なし
パスワード
   Private Sub CommandButton1_Click()
  Dim FName As Variant, CAry As Variant, x As Variant
  Dim MyB As Workbook, TgB As Workbook
  Dim MyS As Worksheet
  Dim i As Long, j As Long
  
  With Application
    FName = _
    .GetOpenFilename("Excelファイル,*.xls,すべてのファイル,*.*", _
    MultiSelect:=True)
    If VarType(FName) = 11 Then Exit Sub
    '↑他には If Not IsArray(FName) Then という条件なども可能
    .ScreenUpdating = False
  End With
  On Error Resume Next
  Set MyB = Workbooks("出力フォーム.xls")
  If Err.Number <> 0 Then
    Set MyB = Workbooks _
    .Open(ThisWorkbook.Path & "\出力フォーム.xls")
    Err.Clear
  End If
  On Error GoTo 0
  Set MyS = MyB.Worksheets("Sheet1")
  CAry = Array(1, 2, 10, 14, 16)
  For Each x In FName
    Set TgB = Workbooks.Open(x)
    With TgB.Worksheets(1)
     NyS.Range("A6").Value = .Range("G1").Value
     MyS.Range("B6").Value = .Range("G2").Value
     For i = 0 To 4
       MyS.Range(MyS.Cells(6, i + 20), MyS.Cells(19, i + 20)) _
       .Value = _
       .Range(.Cells(17, CAry(i)), .Cells(30, CAry(i)).Value
     Next i
    End With
    TgB.Close False: Set TgB = Nothing
    MyB.SaveCopyAs Format(Now, "yy-mm-dd hh-mm-ss") & _
    " _" & CStr(i) & ".xls"
  Next     
  Set MyS = Nothing: Set MyB = Nothing  
End Sub

で、どうでしょーか ?

【30553】Re:ファイル選択をキャンセルした際の抜...
発言  Kein  - 05/10/30(日) 19:20 -

引用なし
パスワード
     Application.ScreenUpdating = True
End Sub

と、最後のところに入れておいて下さい。

【30555】Re:ファイル選択をキャンセルした際の抜...
質問  kino  - 05/10/30(日) 21:04 -

引用なし
パスワード
   Kein さん、はじめまして。
さっそく教えていただき、ありがとうございます。

ファイル選択をキャンセルした際の抜け方は、教えていただいた方法で成功しました。

わからない部分があるのですが、

>  For Each x In FName
>    Set TgB = Workbooks.Open(x)
>    With TgB.Worksheets(1)
>     NyS.Range("A6").Value = .Range("G1").Value
>     MyS.Range("B6").Value = .Range("G2").Value
>     For i = 0 To 4
>       MyS.Range(MyS.Cells(6, i + 20), MyS.Cells(19, i + 20)) _
>       .Value = _
>       .Range(.Cells(17, CAry(i)), .Cells(30, CAry(i)).Value
>     Next i
>    End With


↑部分の Withステートメント
>     NyS.Range("A6").Value = .Range("G1").Value
で実行時エラー'424'オブジェクトが必要です。とエラーが出ます。

Withステートメントをコメントアウトして、オブジェクトを指定してもエラーになるのですが、どこを見ればいいのでしょうか?

お手数をかけますが、お時間がありましたらご教授ください。

【30556】Re:ファイル選択をキャンセルした際の抜...
発言  かみちゃん  - 05/10/30(日) 21:13 -

引用なし
パスワード
   こんにちは。かみちゃん です。

横から失礼します。

>↑部分の Withステートメント
>>     NyS.Range("A6").Value = .Range("G1").Value
>で実行時エラー'424'オブジェクトが必要です。とエラーが出ます。

NysS ではなく、MySの誤植ではないかと思われます。

【30559】Re:ファイル選択をキャンセルした際の抜...
発言  Kein  - 05/10/30(日) 21:38 -

引用なし
パスワード
   すいません。かみちゃんさんのご指摘のとおりです。他のところでもデバッグする
可能性はありますが、その際はまずタイプミスを疑ってみて下さい。

【30568】Re:ファイル選択をキャンセルした際の抜...
お礼  kino  - 05/10/31(月) 2:25 -

引用なし
パスワード
   kein さん、かみちゃん さん、お世話になりました。
ありがとうございました。
またよろしくお願いします。

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