Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос сбора данных - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Макрос сбора данных
EnicheV Дата: Вторник, 10.09.2019, 12:39 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Sub Собираем_данные_по_сотрудникам()
Sheets("ОБЩИЙ").Select
ActiveWindow.SelectedSheets.Delete
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "ОБЩИЙ"
Sheets("ОБЩИЙ").Select
Sheets("ОБЩИЙ").Move Before:=Sheets(1)
Dim iRng As Range
Dim iRngAddress As String, oAwb As String, oFile
Dim lLastRow As Long, lLastRowMyBook As Long
Dim iLastColumn As Integer
Dim Str() As String


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
Sheet.Activate
lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column
lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row
iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address
Sheet.Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress)

Next Sheet
Workbooks(oAwb).Close False
Next oFile

End With

Application.ScreenUpdating = True
MsgBox "ГОТОВО!"
End Sub

Помогите решить вопрос чтобы макрос собирал данные не со всей открываемой книги, а только с Листа 1
ХЕЛП!!!
 
Ответить
СообщениеSub Собираем_данные_по_сотрудникам()
Sheets("ОБЩИЙ").Select
ActiveWindow.SelectedSheets.Delete
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "ОБЩИЙ"
Sheets("ОБЩИЙ").Select
Sheets("ОБЩИЙ").Move Before:=Sheets(1)
Dim iRng As Range
Dim iRngAddress As String, oAwb As String, oFile
Dim lLastRow As Long, lLastRowMyBook As Long
Dim iLastColumn As Integer
Dim Str() As String


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
Sheet.Activate
lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column
lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row
iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address
Sheet.Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress)

Next Sheet
Workbooks(oAwb).Close False
Next oFile

End With

Application.ScreenUpdating = True
MsgBox "ГОТОВО!"
End Sub

Помогите решить вопрос чтобы макрос собирал данные не со всей открываемой книги, а только с Листа 1
ХЕЛП!!!

Автор - EnicheV
Дата добавления - 10.09.2019 в 12:39
китин Дата: Вторник, 10.09.2019, 13:06 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 7029
Репутация: 1078 ±
Замечаний: 0% ±

Excel 2007;2010;2016
EnicheV, - Прочитайте Правила форума
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
СообщениеEnicheV, - Прочитайте Правила форума
- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)

Автор - китин
Дата добавления - 10.09.2019 в 13:06
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!