Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Импорт файлов из папки
 
#1
20.09.2011 11:53:29
Добрый день!  
 
Подскажите, пожалуйста.  
 
Есть макрос импорта файла. Что нужно добавить/изменить в нем, чтобы для импорта требовалось указать только папку с файлами. Макрос в свою очередь брал все файлы из этой папки и подгружал на один лист друг под другом.  
 
Код макроса:  
 
   With ActiveSheet.QueryTables.Add(Connection:= _  
       "TEXT;C:\моя_папка\файл.bdt" _  
       , Destination:=Range("$B$2"))  
       .Name = "файл"  
       .FieldNames = True  
       .RowNumbers = False  
       .FillAdjacentFormulas = False  
       .PreserveFormatting = True  
       .RefreshOnFileOpen = False  
       .RefreshStyle = xlInsertDeleteCells  
       .SavePassword = False  
       .SaveData = True  
       .AdjustColumnWidth = True  
       .RefreshPeriod = 0  
       .TextFilePromptOnRefresh = False  
       .TextFilePlatform = 1252  
       .TextFileStartRow = 1  
       .TextFileParseType = xlDelimited  
       .TextFileTextQualifier = xlTextQualifierDoubleQuote  
       .TextFileConsecutiveDelimiter = False  
       .TextFileTabDelimiter = True  
       .TextFileSemicolonDelimiter = False  
       .TextFileCommaDelimiter = False  
       .TextFileSpaceDelimiter = False  
       .TextFileOtherDelimiter = ":"  
       .TextFileTrailingMinusNumbers = True  
       .Refresh BackgroundQuery:=False  
       .Delete  
   End With  
 
 
Нашел в интернете макрос:  
ub NN()  
Dim dirPath As String  
dirPath = "C:\Моя папка\"  
Dim filePath As String  
filePath = Dir(dirPath)  
While filePath <> ""  
        Workbooks.OpenText Filename:=dirPath & filePath  
        Range(Selection, Selection.End(xlDown)).Select  
        Selection.Copy  
        ThisWorkbook.Activate  
        Cells(ThisWorkbook.ActiveSheet.UsedRange.Rows.Count + 1, 1).Select  
        ActiveSheet.Paste  
        Windows(filePath).Activate  
        ActiveWindow.Close  
     filePath = Dir  
Wend  
End Sub    
 
но он некорректно работает если в файлах разное кол-во разделителей..  
 
 
Буду очень признателен за помощь!!
 
 
 
#2
20.09.2011 13:09:35
Dim FD As FileDialog  
Dim iTempFileName As String     'имя по-очерёдно открываемого файла  
Dim Wb As Workbook              'текущая книга (где исполняемый код)  
Dim tWb As Workbook             'открываемая книга  
Dim iPath As String             'путь к папке, где лежат все файлы  
Dim iNumFiles As Long           'количество открываемых файлов  
   
    Set Wb = ThisWorkbook  
   
'Диалог выбора папки с файлами  
   Set FD = Application.FileDialog(msoFileDialogFolderPicker)  
   With FD  
       .AllowMultiSelect = False  
       .InitialFileName = ThisWorkbook.Path & Application.PathSeparator  
       .Title = "Выберите папку с нужными файлами "  
       .ButtonName = "Выбрать"  
       If .Show = False Then  
           MsgBox "Вы не указали папку!", 48, "Конец"  
           Exit Sub  
       Else  
           iPath = .SelectedItems(1) & Application.PathSeparator  
       End If  
   End With  
   Set FD = Nothing  
 
 
   iTempFileName = Dir(iPath & "*.xls")  
   Do While iTempFileName <> ""  
       If iTempFileName <> Wb.Name Then  
           iNumFiles = iNumFiles + 1  
'открываем книгу              
Set tWb = Workbooks.Open _  
                   (Filename:=iPath & iTempFileName, UpdateLinks:=False,    
   
                   
  'здесь текст вашего макроса, т.е. то что вы будете делать с открытым  
  'файлом                                      
       
                 
      End If  
           tWb.Close SaveChanges:=False   ' закрыть книгу без сохранения    
                                          'изменений  
         
       iTempFileName = Dir      ' следующая книга для подсчета    
   Loop
 
 
 
#3
20.09.2011 14:22:32
Kuzmich, спасибо большое.  
 
Ваше решение настолько универсально (по крайней мере, для такого новичка в vba как я), что с легкостью адаптируется под многие мои задачи, связанные с открытием файлов.    
 
Еще раз спасибо вам за удиленное время и ценный для меня код.
 
 
 
#4
20.09.2011 14:23:40
Поискать готовое решение не пробовали?  
http://excelvba.ru/code/DATfolder2Array  
 
Надо-то всего ничего:  
 
 
On Error Resume Next  
 Dim coll As New Collection, filename  
   filename = Dir(FolderPath$ & "*.dat")  
   While filename <> ""  
       coll.Add filename    ' считываем в колекцию coll нужные имена файлов  
      filename = Dir  
   Wend  
 
   Dim newtxt As String, ro As String, errIndex As Long  
   For Each filename In coll  
      ' ваш код для файла  
   Next
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#5
20.09.2011 14:32:02
EducatedFool, честно, пробовал и указанная вами страница (впрочем, как и многие другие страницы вашего сайта) есть у меня в закладках в избранном.  
 
Изначально до реализации через импорт пытался сделать на базе вашего кода http://excelvba.ru/code/DATfolder2Array  
но меня сбил с толку код:  
DataArr = DATfolder2Array(Папка, 7, "1,2,4,5", ErrorsArray)  
Array2worksheet Worksheets("errors"), ErrorsArray, _  
     Array("Имя файла", "Номер строки", "Данные из строки")  
Array2worksheet Worksheets("result"), DataArr, _  
     Array("Ячейка", "Штрих-Код", "Наименование", "код 1С", "код произв.", "кол-во", "счетовод")  
 
Сейчас, гляда на ваш пост, вижу, что мне еще учиться о-о-очень долго ))  
Спасибо!
 
 
 
Страницы: 1
Читают тему
Наверх