Excel VBA質問箱 IV

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

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


2703 / 13645 ツリー ←次へ | 前へ→

【66470】フォルダ内指定シートの指定セル値のコピー ビータン 10/9/5(日) 12:37 質問[未読]
【66471】Re:フォルダ内指定シートの指定セル値のコ... 247b 10/9/5(日) 17:14 回答[未読]
【66476】出来ました! ビータン 10/9/5(日) 21:48 お礼[未読]
【66478】Re:出来ました! 247b 10/9/5(日) 22:23 回答[未読]
【66483】Re:出来ました! ビータン 10/9/5(日) 23:04 お礼[未読]
【66486】Re:出来ました! 247b 10/9/5(日) 23:44 発言[未読]
【66501】Re:出来ました! ビータン 10/9/6(月) 22:31 お礼[未読]

【66470】フォルダ内指定シートの指定セル値のコピ...
質問  ビータン E-MAIL  - 10/9/5(日) 12:37 -

引用なし
パスワード
   こんちわ、VBA初心者です、宜しくお願いします。

フォルダ内に置いた”指定セル値参照xls”を使って、他の複数ファイルの 特定する" 表紙 "シート にあるA1セルの値を(但し" 表紙 "シートがないファイルもありその時は空白セルのままで進めたいのです,
この”指定セル値参照xls”にある入力シートのA1セルから順にA2、3・・・と入力したいのですが上手くいきません)。
他のファイルを開いたときにアクティブに出来ないみたいで、エラーになります。

昨日からず〜〜と やってますが どうしても上手くいきません、どなたか ご指導願います、宜しくお願いします。


Sub test()
'
'フォルダ内指定シートの指定セル値のコピー、入力シートに貼付


 myAD = ThisWorkbook.Path & "\"
  Filename = Dir(myAD & "*.xls")

  Do Until Filename = ""
      If Filename <> "指定セル値参照.xls" Then
        Set aBN = Workbooks.Open(myAD & Filename)
        Application.ScreenUpdating = False
   
  For Each ws In Worksheets
    If ws.Name = " 表紙 " Then
      If Worksheets.Count > 1 Then
  Sheets(" 表紙 ").Select
  Sheets(" 表紙 ").Activate
  SelectedSheets.Range("A1").Copy


       End If
    End If
  Next

  Windows("指定セル値参照.xls").Activate
  ActiveWorkbook.Worksheets("入力シート").Select

 
  Dim i As Long
  With ActiveCell
    For i = .Row + 1 To Rows.Count
      If Not Rows(i).Hidden Then
        Cells(i, .Column).Select
        Exit For
      End If
    Next
  End With
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
   
        aBN.Save
        aBN.Close
      End If
      Filename = Dir()
  Loop

Application.ScreenUpdating = False


End Sub

【66471】Re:フォルダ内指定シートの指定セル値の...
回答  247b  - 10/9/5(日) 17:14 -

引用なし
パスワード
   ▼ビータン さん:
こんばんわ 247bです。

こんな感じですか?
変数は宣言しましょう。
インデントを使った方がプログラムが見やすくなります。
Scriptingコンポーネントというのを使っています。


Option Explicit

Dim cnt As Long
Dim sh As Worksheet

Sub Main()
'
'フォルダ内指定シートの指定セル値のコピー、入力シートに貼付
  Dim fso As Object
  Dim fld As Object
  Dim fls As Object
  Dim aBN As Workbook
  Dim ws As Worksheet
  Dim myAD As String
  
  Application.ScreenUpdating = False
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set sh = Workbooks("指定セル値参照.xls").Worksheets("入力シート")

  cnt = 1
  myAD = ThisWorkbook.Path & "\"
  'Filename = Dir(myAD & "*.xls")
  Set fld = fso.GetFolder(myAD)

  'Do Until Filename = ""
  For Each fls In fld.Files
    If fls.Name <> "指定セル値参照.xls" Then
      If UCase(fso.GetExtensionName(fls.Name)) = "XLS" Then
         'Set aBN = Workbooks.Open(myAD & Filename)
         'Application.ScreenUpdating = False
        
        Set aBN = Workbooks.Open(fls.Path)
        For Each ws In aBN.Worksheets
          If Worksheets.Count > 1 Then
            If ws.Name = " 表紙 " Then
  '            If Worksheets.Count > 1 Then
  '              Sheets(" 表紙 ").Select
  '              Sheets(" 表紙 ").Activate
  '              SelectedSheets.Range("A1").Copy
  '             End If
              sh.Cells(cnt, 1).Value = ws.Cells(1, 1).Value
              cnt = cnt + 1
              Exit For
            End If
          End If
        Next
        aBN.Saved = True
        aBN.Close
        Set aBN = Nothing
       End If
    End If
  Next
  'Loop

  Application.ScreenUpdating = True
End Sub

  
'  Dim i As Long
'
'  With ActiveCell
'    For i = .Row + 1 To Rows.Count
'      If Not Rows(i).Hidden Then
'        Cells(i, .Column).Select
'        Exit For
'      End If
'    Next
'  End With
'  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'    :=False, Transpose:=False
'
'        aBN.Save
'        aBN.Close
'      End If
'      Filename = Dir()
'  Loop

  
'Application.ScreenUpdating = False
'
'
'End Sub

【66476】出来ました!
お礼  ビータン E-MAIL  - 10/9/5(日) 21:48 -

引用なし
パスワード
   ▼247b さん:
こんばんわ 247b さん

遅くなりまして申し訳ありません。
見事に出来ました、処理スピードも早くてすばらしい出来です、ありがとうございました。

只一つ、今更ですが " 表紙 "シートが無いファイルがあった時に
ブランクセルでもあった方が、どのファイルのものか判別し易かったかなって思います、図々しいことですが、出来たらそこまでお願いしても宜しいでしょうか。
自分でも頑張って見ます。

本当に有難うございました、またのご指導をお願い致します。

【66478】Re:出来ました!
回答  247b  - 10/9/5(日) 22:23 -

引用なし
パスワード
   ▼ビータン さん:
こんばんわ

こんな感じでどうですか。
この版だと、
B列にファイル名を表示する。
表示シートがない場合はA列は空白になる
表示シートがあり、A1が空白の場合空白になる
という仕様になっているはずです。

Option Explicit

Dim cnt As Long
Dim sh As Worksheet

Sub Main()
'
'フォルダ内指定シートの指定セル値のコピー、入力シートに貼付
  Dim fso As Object
  Dim fld As Object
  Dim fls As Object
  Dim aBN As Workbook
  Dim ws As Worksheet
  Dim myAD As String
  
  Application.ScreenUpdating = False
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set sh = Workbooks("指定セル値参照.xls").Worksheets("入力シート")

  cnt = 1
  myAD = ThisWorkbook.Path & "\"
  'Filename = Dir(myAD & "*.xls")
  Set fld = fso.GetFolder(myAD)

  'Do Until Filename = ""
  For Each fls In fld.Files
    If fls.Name <> "指定セル値参照.xls" Then
      If UCase(fso.GetExtensionName(fls.Name)) = "XLS" Then
         'Set aBN = Workbooks.Open(myAD & Filename)
         'Application.ScreenUpdating = False
        
        Set aBN = Workbooks.Open(fls.Path)
        For Each ws In aBN.Worksheets
          If Worksheets.Count > 1 Then
            If ws.Name = " 表紙 " Then
  '            If Worksheets.Count > 1 Then
  '              Sheets(" 表紙 ").Select
  '              Sheets(" 表紙 ").Activate
  '              SelectedSheets.Range("A1").Copy
  '             End If
              If Not IsEmpty(ws.Cells(1, 1).Value) Then
                sh.Cells(cnt, 1).Value = ws.Cells(1, 1).Value
              End If
              sh.Cells(cnt, 2).Value = fls.Name
              cnt = cnt + 1
              Exit For
            Else
              sh.Cells(cnt, 2).Value = fls.Name
              cnt = cnt + 1
              Exit For
            End If
          End If
        Next
        aBN.Saved = True
        aBN.Close
        Set aBN = Nothing
      End If
    End If
  Next
  'Loop

  Application.ScreenUpdating = True
End Sub

【66483】Re:出来ました!
お礼  ビータン E-MAIL  - 10/9/5(日) 23:04 -

引用なし
パスワード
   247b さん

有難うございます、早速試してみました、が

>B列にファイル名を表示する。・・・・・・・・・・・・・バッチリです

>表示シートがない場合はA列は空白になる・・・・・・・・バッチリです

>表示シートがあり、A1が空白の場合空白になる・・・・・・バッチリです


・表示シートがあり、A1が空白でない場合も空白になってしまいました。


最初に頂いた構文を何とか理解して頑張ります。

重ね重ね 有難うございました。

【66486】Re:出来ました!
発言  247b  - 10/9/5(日) 23:44 -

引用なし
パスワード
   ▼ビータン さん:
>
>・表示シートがあり、A1が空白でない場合も空白になってしまいました。

こちらで検証した限りでは問題ないようなのですが。。。

【66501】Re:出来ました!
お礼  ビータン E-MAIL  - 10/9/6(月) 22:31 -

引用なし
パスワード
   ▼247b さんへ


返信 有難うございました、

何度やっても出来なくて、2度目に頂いた文をよくよく見てたら

              ・・・・・

              If Not IsEmpty(ws.Cells(1, 1).Value) Then
                sh.Cells(cnt, 1).Value = ws.Cells(1,                 1).Value
              End If
              sh.Cells(cnt, 2).Value = fls.Name
              cnt = cnt + 1
              Exit For
            Else
             sh.Cells(cnt, 2).Value = fls.Name
             cnt = cnt + 1
             Exit For
            End If
          End If
          
          ・・・・・


となってまして、下記の部分が同じだったので試しに消して実行したらバッチリ出来ました。すごい感激ものでした!

              ・・・・

              sh.Cells(cnt, 2).Value = fls.Name
              cnt = cnt + 1
              Exit For

              ・・・・

本当に有難うございました。

又、困ったときには 御指導願います。

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