Excel VBA質問箱 IV

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

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


21927 / 76734 ←次へ | 前へ→

【60193】複数のエクセルデータの集計
質問  たかし  - 09/2/3(火) 18:03 -

引用なし
パスワード
   お世話になっています。

履歴を参考に、複数のエクセルデータの集計用マクロを作成していますが、うまくいきません。どなたか、アドバイス願います。

任意のホルダに、同一形式のエクセルシートを保存しています。
マクロにてホルダ内の任意のエクセルファイルを選択し、集計したいファイルのPathを取得。
ホルダ内のエクセルファイル全ての、"Sheet1"のデータを、1つのシート(マクロ作成してあるエクセルの"Anal"シート)にまとめる。

作成したマクロ

Sub test()
 Dim FSO As Object
 Dim MyPath As String, folpath As String, folmei As String, fmei As String
 Dim fbasename As String, kaku As String, strPath As String
 Dim vntFileName As Variant
 Dim DataJ As Range
 Dim i, j
' Dim 新規Sheet As Object, 既存Sheet As Object
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  
  vntFileName1 = ThisWorkbook.Name
  
  If GetWriteFile(vntFileName, strPath) Then
   
   MyPath = vntFileName            'ファイルのフルパス
   folpath = FSO.getparentfoldername(MyPath)  'フォルダのパス
   folmei = FSO.getfolder(folpath).Name    'フォルダ名
   fmei = FSO.getfile(MyPath).Name       'ファイル名
   fbasename = FSO.getbasename(MyPath)     'ファイル名から拡張子を除いた部分
   kaku = FSO.GetExtensionName(MyPath)     '拡張子
   
   xlsFile = Dir(folpath & "\*.xls")
   
   Do While xlsFile <> ""
    Workbooks.Open folpath & "\" & xlsFile
    
    j = Workbooks(xlsFile).Worksheets("Sheet1").Range("F65536"). _
      End(xlUp).Row
    Set DataJ = Workbooks(xlsFile).Worksheets("Sheet1"). _
      Range("A3:R" & j)
    
    i = Workbooks(vntFileName1).Worksheets("Anal"). _
      Range("F65536").End(xlUp).Row
    DataJ.Copy Workbooks(vntFileName1). _
      Worksheets("Anal").Range("A" & i)
    
    Set DataJ = Nothing
    
    Workbooks(xlsFile).Activate
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close    
   Loop
  End If
  Set FSO = Nothing
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

上記マクロでは、フォルダ内の選択したファイルだけで、無限ループに入ってしまいます。修正点を教えていただけないでしょうか?
よろしくお願い致します。
2 hits

【60193】複数のエクセルデータの集計 たかし 09/2/3(火) 18:03 質問
【60195】Re:複数のエクセルデータの集計 にぃ 09/2/3(火) 18:26 発言
【60196】Re:複数のエクセルデータの集計 たかし 09/2/3(火) 18:46 お礼

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