Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 01.02.2012, 18:39   #1
tatianalug
Новичок
Джуниор
 
Регистрация: 01.02.2012
Сообщений: 2
Восклицание объединить несколько разнотипных файлов excel в одну книгу, один лист

Здравствуйте!
помогите пожалуйста разобраться со следующим вопросом
есть 15 файлов excel с разными таблицами (прайс листы), их необходимо объединить в один файл одним листом, что бы полностью сохранялись данные.
Я использовала макрос:

Sub FiziK()

Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат
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("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



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


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Как правильно объединить несколько одинаковых стилей CSS в один файл? -=ButCheR=- HTML и CSS 1 30.10.2010 08:21
Объединение данных из разных файлов на один лист Комо Microsoft Office Excel 11 22.06.2010 21:26
объединение несколько файлов Excel в один лист документа Дмитрий11111111111 Microsoft Office Excel 2 15.02.2010 12:25
Объединить информацию двух файлов с разной датой в один Язычник Microsoft Office Excel 1 19.11.2009 15:56
Слить-объединить несколько файлов в один SLP Microsoft Office Excel 2 19.11.2008 18:13