Объединение листов с предварительным редактированием

[prettyfly]

Требуется помощь знающих людей. Сам я в программировании не силен в VBA в особенности, но требуется достаточно быстро написать макрос. Задача в том чтобы преобразовать документ excel(отчеты с разных регионов, все в одном документе каждый регион на отдельном листе) к виду пригодному для экспорта на сайт(текстовый документ с заданными разделителями). Для того чтобы объединить листы, воспользовался следующим не безызвестным макросом:

Sub Kusp()

Const strStartDir = "d:\" 'папка, с которой начать обзор файлов
Const strSaveDir = "d:\" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = False 'вставлять строку заголовка (книга, лист) перед содержимым листа

Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
i As Integer, stbar As Boolean, clTarget As Range
Dim Cnt As Integer

On Error Resume Next 'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , 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), ReadOnly:=True)
For Each shSrc In wbSrc.Worksheets
If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
Set clTarget = shTarget.Range("A1").Offset(shTarge t.Range("A1").SpecialCells(xlCellTy peLastCell).Row, 0)
If blInsertNames Then
clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
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

Столкнулся со следующими проблемами:
1) До обработки книги данным макросом книга нуждается в редактировании(убрать первый лист, удалить заголовок), не подскажите в какую часть данного кода можно подставить необходимые строки?
2) Как можно сосчитать количество заполненных строк в документе?количество листов?
3) Как применить преобразование ко всем листам книги(к примеру удаление первых 2ух строк)
4) Как преобразовать полученную книгу в текстовый документ

[EducatedFool]

Слишком много вопросов)
И не факт, что ответы на них помогут вам написать работающий макрос.

Будет проще написать макрос "с нуля" - под ваши требования.

Прикрепите к сообщению:

1) папку с 2-3 файлами, которые требуется обработать
(выделив в них зелёным цветом все ячейки (на всех листах), которые должны попасть в результат)
2) текстовый файл - пример того, что должно получиться на выходе
(хватит 2-10 заполненных строк)


Обрабатывать надо все файлы XLS из выбранной папки, или надо выбирать отдельные файлы из этой папки?

[prettyfly]

Спасибо за ваше участие! Файл xls всего один, но с множеством листов. Надо собрать их в новый документ на один лист, чтобы потом его потом можно преобразовать в текстовый.

Прикладываю пример

[EducatedFool]

Не совсем то, что вам надо, но всё же...

1) Откройте свой файл ("исходный"), и мой файл (с макросом)
ВНИМАНИЕ: не должно быть открыто других файлов)

2) в моём файле нажмите зелёную кнопку

PS: Обработку столбцов (объединение, форматирование, перестановку столбцов) не делал.

Вот весь код:

Sub Макрос()
    Dim WB As Workbook, ra As Range, ra2 As Range
    Set WB = GetAnotherWorkbook
    If WB Is Nothing Then MsgBox "Книга не выбрана", vbCritical: Exit Sub

    Application.ScreenUpdating = False
    shd.UsedRange.ClearContents
    ' обработка данных из выбранной книги
    Dim sh As Worksheet: On Error Resume Next
    For Each sh In WB.Worksheets    ' перебираем все листы
        Err.Clear: x = sh.UsedRange.SpecialCells(xlCellTypeFormulas).Count
        ' обрабатываем только листы без формул (кроме первого) с непустой ячейкой А5
        If Err > 0 And Len(Trim(sh.[A5])) > 0 Then
            Debug.Print sh.Name
            ' диапазон заполненных ячеек в столбце а
            Set ra = sh.Range(sh.[A5], sh.Range("A" & sh.Rows.Count).End(xlUp))
            Set ra2 = shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count)
            ra2.Value = sh.Name
            ra2.Offset(, 1).Resize(, 25).Value = ra.Resize(, 25).Value
        End If
    Next sh
    shd.UsedRange.EntireColumn.AutoFit
End Sub

[prettyfly]

Спасибо большое - это макрос гораздо легче понять, а комментарии помогут сделать остальное. Вы настоящий джедай VBA!

[prettyfly]

Возник еще один вопрос по работе макроса, при его использовании в половине ячеек с датами месяц и день поменялись местами и выглядит это так 7/16/2010, а другие в том же столбце остались как и были в нужном формате 08.12.2010. В исходном документе все даты вида чч.мм.гггг.
Не подскажите чем - это вызвано и как исправить?

[prettyfly]

Присмотрелся внимательнее - инвертировались те даты где значение день>12, таким образом как то сработал авто формат по типу западных дат.
Вопрос как это исправить остается в силе.