Добрый день! Хотел сводную таблицу , но не получилось т.к. книг много, подсказали что без макроса тут никак, ну а в мактосах непонимаю вааще ничего. Отчеты приходят каждый день. Для формирования разнорядки нужен лист "сбор" именно в таком виде. Много искал но похожего ничего не нашел. Помогите собрать данные со всех книг в одну.
Добрый день! Хотел сводную таблицу , но не получилось т.к. книг много, подсказали что без макроса тут никак, ну а в мактосах непонимаю вааще ничего. Отчеты приходят каждый день. Для формирования разнорядки нужен лист "сбор" именно в таком виде. Много искал но похожего ничего не нашел. Помогите собрать данные со всех книг в одну.ZamoK
Нашел такой макрос - но он ничего не собирает - что не так? [vba]
Код
Sub Кнопка8_Щелчок() Dim iPivotRange As Range, iDestinationRange As Range, iBeginRange As Range, Sheet Dim iRngAddress As String, oAwb As String, DataSheet As String, _ iCopyAddress As String, sSheetName As String, oFile Dim lLastrow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) DataSheet = ThisWorkbook.ActiveSheet.Name On Error Resume Next Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) If iBeginRange Is Nothing Then Exit Sub sSheetName = "Лист3" If sSheetName = "" Then sSheetName = "*" On Error GoTo 0 With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub For Each oFile In .SelectedItems Workbooks.OpenText Filename:=oFile oAwb = Dir(oFile, vbDirectory)
Application.ScreenUpdating = False Workbooks(oAwb).Activate For Each Sheet In Sheets If Sheet.Name Like sSheetName Then Sheet.Activate Select Case iBeginRange.Count Case 1 lLastrow = Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = Cells.SpecialCells(xlLastCell).Column iCopyAddress = Range(Cells(iBeginRange.Row, iBeginRange.Column), Cells(lLastrow, iLastColumn)).Address Case Else iCopyAddress = iBeginRange.Address lLastrow = iBeginRange.Rows.Count iLastColumn = iBeginRange.Columns.Count End Select lLastRowMyBook = ThisWorkbook.Sheets(DataSheet).Cells.SpecialCells(xlLastCell).Row + 1 iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address Sheet.Range(iCopyAddress).Copy Destination:=ThisWorkbook.Sheets(DataSheet).Range(iRngAddress) End If Next Sheet Workbooks(oAwb).Close False Next oFile End With Application.ScreenUpdating = True End Sub
[/vba]
Нашел такой макрос - но он ничего не собирает - что не так? [vba]
Код
Sub Кнопка8_Щелчок() Dim iPivotRange As Range, iDestinationRange As Range, iBeginRange As Range, Sheet Dim iRngAddress As String, oAwb As String, DataSheet As String, _ iCopyAddress As String, sSheetName As String, oFile Dim lLastrow As Long, lLastRowMyBook As Long Dim iLastColumn As Integer Dim Str() As String
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) DataSheet = ThisWorkbook.ActiveSheet.Name On Error Resume Next Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) If iBeginRange Is Nothing Then Exit Sub sSheetName = "Лист3" If sSheetName = "" Then sSheetName = "*" On Error GoTo 0 With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = "*.*" .Title = "Выберите файлы" If .Show = False Then Exit Sub For Each oFile In .SelectedItems Workbooks.OpenText Filename:=oFile oAwb = Dir(oFile, vbDirectory)
Application.ScreenUpdating = False Workbooks(oAwb).Activate For Each Sheet In Sheets If Sheet.Name Like sSheetName Then Sheet.Activate Select Case iBeginRange.Count Case 1 lLastrow = Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = Cells.SpecialCells(xlLastCell).Column iCopyAddress = Range(Cells(iBeginRange.Row, iBeginRange.Column), Cells(lLastrow, iLastColumn)).Address Case Else iCopyAddress = iBeginRange.Address lLastrow = iBeginRange.Rows.Count iLastColumn = iBeginRange.Columns.Count End Select lLastRowMyBook = ThisWorkbook.Sheets(DataSheet).Cells.SpecialCells(xlLastCell).Row + 1 iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address Sheet.Range(iCopyAddress).Copy Destination:=ThisWorkbook.Sheets(DataSheet).Range(iRngAddress) End If Next Sheet Workbooks(oAwb).Close False Next oFile End With Application.ScreenUpdating = True End Sub
Работает отлично, но вот маленькая неувязочка в окне файлы выбирать приходится по одному а их несколько десятков, можно ли както доработать чтоб сразу все выделить, ну кроме того в котором работаю
Работает отлично, но вот маленькая неувязочка в окне файлы выбирать приходится по одному а их несколько десятков, можно ли както доработать чтоб сразу все выделить, ну кроме того в котором работаюZamoK
Я только начинаю что-то соображать, логически понимаю что тут нехватает какого-то "переборщика" Пытаюсь понять что тут что? уже кипю шипю и пузурюся [spoiler][vba]
Код
Sub push_me_hard() Dim fPath$ Dim spPath, spName Dim a() Dim i& With Application.FileDialog(msoFileDialogFilePicker) .Filters.Clear .Filters.Add "Microsoft Excel files", "*.xls" .AllowMultiSelect = True .InitialFileName = ThisWorkbook.Path If .Show = 0 Then Exit Sub fPath = .SelectedItems(1) End With spPath = Split(Replace(fPath, ".xls", ""), "\") 'отрезали от имени лишнее spName = Split(spPath(UBound(spPath)), "-") 'обозначили разделитель Application.ScreenUpdating = False Workbooks.Open fPath 'открыли выбранную книгу With ActiveWorkbook 'назначили книгу активной With .ActiveSheet 'назначили лист активным a = .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Value 'скопировали в буфер диапазон End With .Close False 'закрыли книгу End With With Sheets("Сбор") 'начинается цикл заполнения данными lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 For i = 1 To UBound(a) If a(i, 1) <> "" Then .Cells(lr, 1) = spName(0) .Cells(lr, 2) = spName(2) .Cells(lr, 3) = a(i, 1) .Cells(lr, 4) = a(i, 3) .Cells(lr, 5) = a(i, 4) lr = lr + 1 End If Next End With 'а наверно тут надо добавить циклический перебор выделенных файлов Application.ScreenUpdating = True Beep End Sub
Я только начинаю что-то соображать, логически понимаю что тут нехватает какого-то "переборщика" Пытаюсь понять что тут что? уже кипю шипю и пузурюся [spoiler][vba]
Код
Sub push_me_hard() Dim fPath$ Dim spPath, spName Dim a() Dim i& With Application.FileDialog(msoFileDialogFilePicker) .Filters.Clear .Filters.Add "Microsoft Excel files", "*.xls" .AllowMultiSelect = True .InitialFileName = ThisWorkbook.Path If .Show = 0 Then Exit Sub fPath = .SelectedItems(1) End With spPath = Split(Replace(fPath, ".xls", ""), "\") 'отрезали от имени лишнее spName = Split(spPath(UBound(spPath)), "-") 'обозначили разделитель Application.ScreenUpdating = False Workbooks.Open fPath 'открыли выбранную книгу With ActiveWorkbook 'назначили книгу активной With .ActiveSheet 'назначили лист активным a = .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Value 'скопировали в буфер диапазон End With .Close False 'закрыли книгу End With With Sheets("Сбор") 'начинается цикл заполнения данными lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 For i = 1 To UBound(a) If a(i, 1) <> "" Then .Cells(lr, 1) = spName(0) .Cells(lr, 2) = spName(2) .Cells(lr, 3) = a(i, 1) .Cells(lr, 4) = a(i, 3) .Cells(lr, 5) = a(i, 4) lr = lr + 1 End If Next End With 'а наверно тут надо добавить циклический перебор выделенных файлов Application.ScreenUpdating = True Beep End Sub