Поправьте код!!!

[Klim Bassenger]

Есть код, который объединяет книги excel в одну...(нашел на этом форуме)
В нем создается новая книга, куда заносятся данные из разных книг... Всё отлично работает, но мне нужно, чтоб не создавалась новая книга, а вставлялся лист в текущую книгу и туда собиралась информация...
Ну а еще, если не трудно, то чтоб строки, где есть ячейки с заливкой и в которых текст выделен жирным цветов удалялись...

Sub Объединение()
 
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
 
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(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).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

[EducatedFool]

Замените строки
Set wbTarget = Workbooks.Add(template:=xlWorksheet )
Set shTarget = wbTarget.Sheets(1)

на строку
Set shTarget = ActiveWorkbook.Worksheets.Add

Ну и уберите последние строки в макросе:

 .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

(сохранять файл будете вручную)

[Klim Bassenger]

а ЧТО НА СЧЕТ то чтоб строки, где есть ячейки с заливкой и в которых текст выделен жирным цветов удалялись???

И еще ворпос:
Workbooks.Open Filename:= _
"\\Gate02\Exchange\DrobyshAndrey\Жу рналы\Копия Журнал заказов проба 2009.xls"
Sheets("ЛКМ РФ").Select
Range("A3:D3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Вот только, чтоб копировались данные по условию...
В столбце А есть даты (аж с 2005 года)... Так вот мне нужно, чтоб копировались не все данные столбцов, а только те, где, например от 01.01.2009 до 01.04.2009...
Спасибо!

[SAS888]

чтоб копировались не все данные столбцов, а только те, где, например от 01.01.2009 до 01.04.2009...

Можно, например, так:

Sub SelectBetween()
    Dim r As Long, x As Range
    Workbooks.Open Filename:="\\Gate02\Exchange\DrobyshAndrey\Журналы\Копия Журнал заказов проба 2009.xls"
    Application.ScreenUpdating = False: Sheets("ЛКМ РФ").Activate
    With Columns("A:D")
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:=">=39814", Operator:=xlAnd, Criteria2:="<39904"
        r = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
        Set x = Intersect(Range([A2], Cells(r, "D")), Cells.SpecialCells(xlCellTypeVisible))
        .AutoFilter
    End With
    If Not x Is Nothing Then x.Copy
End Sub

[SAS888]

чтоб строки, где есть ячейки с заливкой и в которых текст выделен жирным цветов удалялись

Можно, например, так (для активного листа):

Sub Del()
    Dim i As Long, x As Range
    For i = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
        If Rows(i).Interior.ColorIndex = xlNone Then Else _
            If x Is Nothing Then Set x = Rows(i) Else Set x = Union(x, Rows(i))
        If Rows(i).Font.Bold = False Then Else _
            If x Is Nothing Then Set x = Rows(i) Else Set x = Union(x, Rows(i))
    Next
    If Not x Is Nothing Then x.Delete
End Sub

[Klim Bassenger]

Отлично!!!
Немного подправил и всё работает!

[ascer]

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

[SAS888]

Чтобы, например, ячейке "A1" активного рабочего листа активной рабочей книги присвоить значение ячейки "A1" из первого листа открытого файла "Книга1.xls", можно воспользоваться кодом:

[A1] = Workbooks("Книга1.xls").Sheets(1).[A1]

[ascer]

SAS888, спасибо за совет, но мне он не совсем подходит. У меня под тысячу файлов, в них по три листа с таблицами. Нужно брать таблицы из первого листа каждого файла. Этот код (что в первом посте) я немного подправил, чтоб он брал только первые листы, и он отлично справляется, НО стОит попасться файлу, у которого активным листом при сохранении остался лист2 или лист3, выпадает ошибка.
Вот такой цикл я сделал

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 shSrc.Name <> "Лист1" Then GoTo 30 ' выбор первого листа
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            lastrow = shSrc.Cells.SpecialCells(xlLastCell).Row  'определение номера последней строки
            shSrc.Range(Cells(6, 1), Cells(lastrow, 10)).Copy clTarget 'копирование диапазона от А6 и до конца в новый файл
        End If
30:
     Next

    wbSrc.Close False   'закрыть без запроса на сохранение
Next

[SAS888]

При обращении к очередному файлу, используйте ссылку на первый лист (Sheets(1)).
Или дайте пример Вашего кода и укажите, в какой строке возникает ошибка.