|
|
Регистрация Восстановить пароль |
Повторная активизация e-mail |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
Опции темы | Поиск в этой теме |
10.04.2009, 12:00 | #1 |
Форумчанин
Регистрация: 20.01.2009
Сообщений: 138
|
Поправьте код!
Есть код, который объединяет книги 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(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
Чтобы правильно задать вопрос, надо знать большую часть ответа.
|
10.04.2009, 15:46 | #2 |
Пользователь
Регистрация: 27.03.2009
Сообщений: 78
|
для обращения к текущей книге используй
ThisWorkbook |
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Поправьте код!!! | Klim Bassenger | Microsoft Office Excel | 15 | 27.05.2009 15:24 |
Поправьте, пожалуста! | liver1981 | Общие вопросы C/C++ | 14 | 28.03.2009 06:45 |
MASM: HelloWorld разобрался в коде, поправьте немного | N!ckeL | Помощь студентам | 6 | 25.02.2009 22:03 |
Код на C++ | Иллидан | Общие вопросы Delphi | 1 | 08.10.2008 14:02 |
непонятный код | Kostua | Помощь студентам | 5 | 27.04.2008 18:17 |