| |
▼たかし さん：
こんにちは！
>上記マクロでは、フォルダ内の選択したファイルだけで、無限ループに入ってしまいます。修正点を教えていただけないでしょうか？
だけの修正点です。
他は詳しく見ていません^^;
xlsFile = Dir()
を入れて次のブックに指定してあげてください。
>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
xlsFile = Dir()
> 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
>
|
|
にぃ
- 09/2/3(火) 18:26 -
