Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
[ Закрыто ] Обработка файлов в указанной папке
 
#1
14.01.2018 23:40:52
Добрый день. Просьба помочь.

Имеется макрос, в нем необходимо самому выбрать файлы для дальнейшей обработки...
Как переделать так, что б выбор был автоматически всех файлов в указанной папке. Спасибо за помощь, рабочий макрос прилагаю.
Код
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Sub Fizik()
  
Const strStartDir = "c:\kaluna\" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\kaluna\" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = True  'вставлять строку заголовка (книга, лист) перед содержимым листа
   
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
   
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("CSV Files (.csv), *.csv", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
  
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
   
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), local:=True)
    For Each shSrc In wbSrc.Worksheets
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = "  "
                Set clTarget = clTarget.Offset(1, 0)
            End If
            shSrc.UsedRange.Copy clTarget
        End If
    Next
    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
      
  
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
'arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
   
'If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
 '   GoTo save_err
'Else
 '   On Error GoTo save_err
  '  wbTarget.SaveAs arFiles
'End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub
 
 
 
#2
14.01.2018 23:43:20
была же такая тема
http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=100040
какой смысл задавать в новой теме тот же вопрос?
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#3
14.01.2018 23:46:04
Тема закрыта и будет удалена - дубль!
 
 
 
Страницы: 1
Читают тему
Наверх
Loading...