Новости:

Из правил форума: Тема должна отражать суть вопроса, топики типа "help please" будут удаляться!

Главное меню

Сводная таблица

Автор Markovki, 20.02.2012, 15:37

« назад - далее »

kuklp

Так, да не так. Внимательней и на текст и на результат. Этот мой вариант как раз оставит автофильтры на скопированных листах.
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

Markovki

Действительно, вы правы...
))

Markovki

While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        ActiveWorkbook.Sheets("НПО").Range("I7").Copy
        ThisWorkbook.Sheets("НПО_ИТОГ").[B2].PasteSpecial xlPasteValues, 2, 0
        Workbooks(Dir(FilesToOpen(x))).Close 0   'Закрывает файл
        x = x + 1
Wend


Подскажите пожалуйста ещё, как переделать этот код, чтобы он смог скопировать значение ячейки "I7" в ячейку "B2", но при этом надо чтобы следующее значение из "I7"(, т.е. из другого файла) скопировалось чуть ниже, в ячейку B3 и т.д.

Макрос остался тот же, но теперь мне надо собрать значения ячейки I7 из разных файлов в таблицу, т.е чтобы эти значения получились в один столбик, файлы открывать и копировать листы нет необходимости.


Markovki

Что-то никак у меня не получается, может кто-нить знает, как правильно это организовать? Какая должна быть конструкция, у меня не получается пока что...

Markovki

Или такой вариант, чтобы выстроить на текущем листе в столбик значения всех I7 собранных со всех листов текущей книги, хотя бы маленький пример.

Markovki

#20
Попробовал вот так:
Dim Z As Integer
While X <= UBound(FilesToOpen)
       Workbooks.Open Filename:=FilesToOpen(X)
       ActiveWorkbook.Sheets("НПО").Select
       Range("I7").Select
       Selection.Copy
       ThisWorkbook.Sheets("НПО_ИТОГ").Activate
       Z = Cells(1, 1).SpecialCells(xlLastCell).Row
       Cells(Z + 1, 1).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=True
       Application.CutCopyMode = False
       Workbooks(Dir(FilesToOpen(X))).Close 0   '
       X = X + 1
Wend

Макрос вроди работает, но ничего не добавляет, в чём проблема?

kuklp

#21
Все он добавляет, только надо же понимать -  куда:-)
Z = Cells(1, 1).SpecialCells(xlLastCell).Row, это то же самое, что нажать клавиши ctrl+end. Нажмите и посмотрите, в какой вы строке оказались. А теперь нажмите Номе и окажетесь в последней вставленной ячейке.
Кстати, то что Вы написали, лучше записать так(без прыготни по листам и ячейкам):
Dim Z As Integer
While x <= UBound(FilesToOpen)
       Workbooks.Open Filename:=FilesToOpen(x)
       Z = ThisWorkbook.Sheets("НПО_ИТОГ").Cells(1, 1).SpecialCells(xlLastCell).Row
       ThisWorkbook.Sheets("НПО_ИТОГ").Cells(Z + 1, 1).Value = _
       ActiveWorkbook.Sheets("НПО").Range("I7")
       Workbooks(Dir(FilesToOpen(x))).Close 0   '
       x = x + 1
Wend

Старайтесь избегать команд select и activate.
Насчет "B2" - на скрине выделена эта ячейка. Ниже идут объединенные ячейки, поэтому ячеек В3, В4 как бы и не существует... Врядли Вам хотелось именно этого, так что на будущее старайтесь четче формулировать свои хотелки.
Если все же решитесь убрать объединение ячеек, то так:
While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        ThisWorkbook.Sheets("НПО_ИТОГ").Cells(x + 1, 2).Value = _
        ActiveWorkbook.Sheets("НПО").Range("I7")
        Workbooks(Dir(FilesToOpen(x))).Close 0   '
        x = x + 1
Wend
Удачи.
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

Markovki

#22
Ага) разобрался) Спасибо :)
Согласен, что надо было задачу более конкреную поставить, хотел упростить.
В результате создал чистый файл с тем же макросом и вот, что получилось в итоге:
Dim Z As Integer
With Range("A1:E1")
   .Font.Bold = True
   .Font.Size = 12
End With
   Range("A1").Value = "Имя файла(Предприятия)"
   Range("B1").Value = "НПО"
   Range("C1").Value = "СПО"
   Range("D1").Value = "ВПО"
While x <= UBound(FilesToOpen)
       Workbooks.Open Filename:=FilesToOpen(x)
       Z = ThisWorkbook.Sheets("ПРОВЕРКА").Cells(2, 2).SpecialCells(xlLastCell).Row
       fname = ActiveWorkbook.Name
       ThisWorkbook.Sheets("ПРОВЕРКА").Cells(Z + 1, 1) = fname
       ThisWorkbook.Sheets("ПРОВЕРКА").Cells(Z + 1, 2).Value = _
       ActiveWorkbook.Sheets("НПО").Range("I7")
       ThisWorkbook.Sheets("ПРОВЕРКА").Cells(Z + 1, 3).Value = _
       ActiveWorkbook.Sheets("СПО").Range("I7")
       ThisWorkbook.Sheets("ПРОВЕРКА").Cells(Z + 1, 4).Value = _
       ActiveWorkbook.Sheets("СПО").Range("I7")
       Workbooks(Dir(FilesToOpen(x))).Close 0   '
       x = x + 1
Wend


Теперь необходимо добавить рядом в столбик исключительно расширение файла, это необходимо для проверки, т.к. иногда попадаются левые файлы типа ods и xlsx и т.д. чтобы в дальнейшем исключить их или сохранить в надлежащем формате.

И ещё, можно ли в конце трех столбцов НПО, СПО, ВПО (столбцы B,C и D соответственно) добавить макросом автосумму? хотя щас сам попробую сделать...

Markovki

И почему-то после очистки листа начинает дальше записывать, например с 5 по 10 строку, а в следующий раз после очистки с 11 строки и т.д. помогает только сохранение документа после очистки, как быть? Может автоматом сохранять документ после каждой очистки?

Попробовал добавить после цикла код, но выдает ошибку:
ActiveWorkbook.save

Markovki

Сегодня подкинули опять новую задачку, всё тоже самое только листы уже собраны в один файл. Те же таблицы один в один.
Есть тот же код:
Sub Добавление_предприятия()
   Dim FilesToOpen
   Dim strFileTitle As String
   Dim x As String
   On Error GoTo ErrHandler
   Application.ScreenUpdating = False
   Const REPORTS_FOLDER = "\"
   ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
   FilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
                  MultiSelect:=True, Title:="Выберите необходимые файлы")
   If TypeName(FilesToOpen) = "Boolean" Then
       MsgBox "Операция отменена пользователем"
       GoTo ExitHandler
   End If
   x = 1
   Application.DisplayAlerts = 0
   
   While x <= UBound(FilesToOpen)
   Application.ScreenUpdating = False
       Workbooks.Open Filename:=FilesToOpen(x)
       fname = ActiveWorkbook.Name
       Sheets("НПО").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
       Workbooks(fname).Sheets("НПО").AutoFilterMode = 0 'отключение [url=http://msexcel.ru/content/view/27/2/]_автофильтр_[/url]а
       Workbooks(fname).Sheets("НПО").[I7].Copy
       ThisWorkbook.Sheets("НПО_ИТОГ").[I6].PasteSpecial xlPasteValues, 2, 0
       Workbooks(fname).Sheets("НПО").Range("D13:J902").Copy
       ThisWorkbook.Sheets("НПО_ИТОГ").[D12].PasteSpecial xlPasteValues, 2, 0
       x = x + 1
       Workbooks(fname).Close
       kol = ThisWorkbook.Sheets.Count
       kol2 = kol - 1
       fname = Left$(Split(fname, ".")(0), 25) & "(" & kol2 & ")"
       ThisWorkbook.Sheets("НПО").Name = fname
   Wend
   Sheets("НПО_ИТОГ").Activate
   Range("D11:D901").Select
   ActiveSheet.Range("$D$11:$D$901").AutoFilter Field:=1, Criteria1:="="
   ActiveSheet.Range("$D$11:$D$901").AutoFilter Field:=1, Criteria1:=">=1", _
   Operator:=xlAnd
ExitHandler:
   Application.DisplayAlerts = -1
   Application.ScreenUpdating = True
   Exit Sub
ErrHandler:
   MsgBox Err.Description
   Resume ExitHandler
End Sub

Как сделать, чтобы собирались теже сведения из тех же ячеек, но со всех листов данной книги, кроме текущего, а не выборкой из файлов?
Если можно хотя бы пример, как организовать цикл, бегающий по листам, кроме текущего?

Markovki

По предыдущему посту:
пошел по-другому пути, который хоть как-то получается, использую макрос сохранения каждого листа в отдельные книги, файлы большие, делается долго... потом опять буду собирать всё уже наметанным способом))
по сбору с листов текущей книги дело пока что так и не двинулось