Столкнулся с проблемой, не могу понять как правильно сделать подсчет строки. Что бы например с одного файла вытягивало конкретный диапазон до пустого поля. И подставляло в таблицу по порядку( без пропуска и перезаписи)
Сейчас у меня в коде перезаписывает только. Если меняю другой диапазон, то он в разнобой добавляет информацию сразу же после 1 алгоритма, а потом 2. Может кто то подскажет как правильно сделать что бы брало диапазон с разных ячеек у другого файла и подставляло все равномерно по полям( диапазон захвата может быть разным, поэтому брал до первого пустого поля)
В принципе в файле на листе пример как должно быть и макрос
aosunproject, попробуйте слепить что-то по аналогии…
Ваш макрос (это больше для помогающих, чтобы не качать файл)
Код
Sub record()
Dim MainWb As Workbook 'текущая книга (общий файл, где макрос)
Dim MainSht As Worksheet 'текущий лист этой книги( там где макрос)
'Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце A
'Dim iPath As String 'путь к папке, где лежат все файлы
'Dim iTempFileName As String 'имя по-очерёдно открываемого файла
'Dim iLastRowTbl As Long 'номер последний строки в текущей таблице
Dim MasivWbs As Variant ' массив файлов книг что будем открывать
Set DestWbk = ThisWorkbook
Dim SrcWbk As Variant
Application.ScreenUpdating = False 'отключаем обновление экрана для скорости
MasivWbs = Application.GetOpenFilename(FileFilter:="Excel Files(*.xls*),*.xls*", Title:="Select File Name to Open", MultiSelect:=False)
If TypeName(MasivWbs) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!" ' Если не было выбрано никаких файлов, то закроет макрос.
Exit Sub
End If
'Dim ws As Worksheet
'For Each ws In MasivWbs
'Set SrcWbk1 = Workbooks.Open(MasivWbs)
'
Set SrcWbk = Workbooks.Open(MasivWbs)
' N = DestWbk.Worksheets(1).Range("F1").CurrentRegion.Rows.Count
'Set wst = SrcWbk.Range("C1", SrcWbk.Cells(LastRow, lastCol))
'lLstr = Cells(Rows.Count, "C7").End(xlUp).Row
SrcWbk.Worksheets(1).Range("C7", Range("C7").End(xlDown)).Copy Destination:=DestWbk.Worksheets(1).Cells((DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count) + 1, 6)
SrcWbk.Worksheets(1).Range("D7", Range("D7").End(xlDown)).Copy Destination:=DestWbk.Worksheets(1).Cells((DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count) + 1, 5)
SrcWbk.Worksheets(1).Range("E7", Range("E7").End(xlDown)).Copy Destination:=DestWbk.Worksheets(1).Cells((DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count) + 1, 8)
'SrcWbk.Worksheets(1).Range("D7", Range("D7").End(xlDown)).Copy Destination:=DestWbk.Worksheets(1).Cells((DestWbk.Worksheets(1).Range("D2").CurrentRegion))
'SrcWbk.Worksheets(1).Range("C7" & StartRow & "C100" & LastRow).Copy Destination:=DestWbk.Worksheets(1).Cells((DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count) + 1, 1)
'SrcWbk.Close savechanges:=False
' SrcWbk1.Close savechanges:=False
'Set SrcWbk = Workbooks.Open(MasivWbs)
'определяем номер последней строки на текущем листе и на листе сборки
'Workbooks.Open ws
'N = DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
'MasivWbs.Worksheets(1).Range("A7:A15").Copy
'задаем исходный диапазон, который надо скопировать с каждого листа - любой вариант на выбор:
'Set wst = ws.Range("A2", ws.Range("A2").SpecialCells(xlCellTypeLastCell))
'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
'ws.Worksheets(1).Range("A7:A15").Copy
' ws = MasivWbs.Range("A2:A7").Copy
'Next ws
'For Each X In MasivWbs
' Workbooks.Open X
'N = MainWb.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
' X.Worksheets(1).Range("A7:А15").Copy Destination:=MainWb.Worksheets(1).Cells("A1" + 1, 1)
' X=( MasivWbs.Worksheets(1).Range("A7:A15").Copy Destination:=MainWb.Worksheets(1).Cells((MainWb.Worksheets(1).Range("A1").CurrentRegion.Rows.Count) + 1, 1)
')+1)
' Next X
' Dim FT As Long
' Dim NewFN As Variant
'NewFN = Application.GetOpenFilename(FileFilter:="Excel Files(*.xls*),*.xls*", Title:="Select File Name to Open", MultiSelect:=True)
'If NewFN = True Then
' MsgBox "No File was selected"
' Exit Sub
'Else
' Workbooks.Open NewFN()
'End If
'Dim X As Integer Dim SrcWbk As Workbook
' Dim SrcWbk As String
' Dim DestWbk As Workbook
'Dim FT As vb
' #import msado28.tlb
' # import msado15.dll
' Set DestWbk = ThisWorkbook
' Application.ScreenUpdating = False 'отключаем обновление экрана для скорости
'вызываем диалог выбора файлов для импорта
'FT = Application.GetOpenFilename _
' ("Excel files(*.xls*),*.xls*", 4, "Выбрать Excel файлы", , True)
'Workbooks.Open (FT)
' If TypeName(FT) = "Boolean" Then
' MsgBox "Не выбрано ни одного файла!"
' Exit Sub
'End If
' Set SrcWbk = Workbooks.Open(FT)
' N = DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
' SrcWbk.Worksheets(1).Range("A7:A15").Copy Destination:=DestWbk.Worksheets(1).Cells((DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count) + 1, 1)
' Set SrcWbk = Workbooks.Open(FT)
'SrcWbk.Worksheets(1).Range("A7:A15").Copy DestWbk.Worksheets(1).Range("A7")
'
'
' For Each X In FT()
' Workbooks.Open X
' N = DestWbk.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
' X.Worksheets(1).Range("A7:А15").Copy Destination:=DestWbk.Worksheets(1).Cells(N + 1, 1)
' Next X
'
'
'Dim WB As Workbook, sh As Worksheet, ra As Range
' Application.ScreenUpdating = False
'Set WB = Nothing:
'Set Sh = Workbooks.Open(Filename, False, True)
' Dim ws As Worksheet
'Set sh = Workbooks.Open(FilesToOpen)
'Set Wt = ThisWorkbook
' будем брать данные с первого листа
' Set wbCurrent = ActiveWorkbook
'Workbooks.Add
'
'
'копируем на итоговый лист шапку таблицы из первого листа
'
'wbCurrent.Worksheets(1).Range("A7:А15").Copy Destination:=wbReport.Worksheets(1).Range("A1")
'проходим в цикле по всем листам исходного файла
' Dim sh As Workbook
'Dim wt As Workbook
' Set sh = Nothing: Set sh = Workbooks.Open(Filename, False, True)
'Set Wt = ActiveSheet
'Set sh = FilesToOpen.Worksheets(1)
' Set wt = ThisWorkbook
' Set sh = Workbooks.Open(FT)
' Dim ws As Worksheet
'For Each ws In FT
'
'определяем номер последней строки на текущем листе и на листе сборки
' Workbooks.Open ws
' N = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
'задаем исходный диапазон, который надо скопировать с каждого листа - любой вариант на выбор:
' Set rngData = FT.Range("A2", FT.Range("A2").SpecialCells(xlCellTypeLastCell))
'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
' rngData.Copy Destination:=ThisWorkbook.Worksheets(1).Cells(N + 1, 1)
' Next ws
'
'проходим по всем выбранным файлам
'X = 1
'Dim rng As Range
' Set rng = Range("A7:A15")
'Dim myArray() As Double, X As Long, N As Long
' X = 1
' N = WorksheetFunction.CountIf(rng, "<>")
' While X <= UBound(FilesToOpen)
' Set importWB = Workbooks.Open(Filename:=FilesToOpen(X))
' Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
' importWB.Close savechanges:=False
' X = X + 1
' Set sh = FilesToOpen.Worksheets(1) ' будем брать данные с первого листа
' ' берем диапазон ячеек с ячейки B1 до последней заполненной в столбце B
' Set ra = sh.Range(sh.Range("A7:A15"), sh.Range("A7:A15" & sh.Rows.Count).End(xlUp))
' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
' shb.Range("A7:A15" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value = _
' Application.WorksheetFunction.Transpose(ra.Value)
' Wend
'ReDim Preserve myArray(X)
'For Each cell In rng
' If cell <> "" And X < N Then
' myArray(X) = cell.Value
' X = X + 1
' If X < N Then ReDim Preserve myArray(0 To X)
'End If
'Next
' Application.ScreenUpdating = True
End Sub
Мой код
Код
Option Explicit
'====================================================================================================
Sub GetTargetsFromFile()
Dim x, arrFrom, arrNew, txt$, r&, c&
Const shName$ = "Лист1" ' задаём имя листа, с которого нужно забрать данные
txt = ActiveWorkbook.Path
If Not PRDX_ChooseFile(txt) Then Exit Sub
Application.ScreenUpdating = False
Workbooks.Open Filename:=txt, UpdateLinks:=False, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, CorruptLoad:=xlRepairFile
On Error Resume Next
arrFrom = ActiveWorkbook.Worksheets(shName).UsedRange.Value2
If Err Then MsgBox "Лист «" & shName & "» ОТСТУТВУЕТ в выбранном файле!", vbCritical, "ОШИБКА ЛИСТА": GoTo ex
If Not IsArray(arrFrom) Then MsgBox "На листе «" & shName & "» НЕТ ДАННЫХ!", vbCritical, "ОШИБКА ДАННЫХ": GoTo ex
On Error GoTo 0
ActiveWorkbook.Close False
arrNew = ActiveSheet.UsedRange.Value2: c = 1
For Each x In Array(2, 4, 6, 9)
c = c + 1
For r = 2 To UBound(arrNew, 1)
arrNew(r, x) = arrFrom(r, c)
Next r
Next x
Worksheets.Add ' удалить или закомментировать, чтобы вставлять в исходные данные, а не на новый лист
Cells(1, 1).Resize(UBound(arrNew, 1), UBound(arrNew, 2)).Value2 = arrNew
ex:
If ActiveWorkbook.FullName <> ThisWorkbook.FullName Then ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub
'====================================================================================================
Private Function PRDX_ChooseFile(DefPath$) As Boolean ' функция для выбора файла
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Выберите Excel-файлы"
.Filters.Clear
.Filters.Add "Файлы Excel", "*.xls?", 1
.FilterIndex = 1
.InitialFileName = DefPath
.InitialView = msoFileDialogViewDetails
If .Show = 0 Then Exit Function
DefPath = .SelectedItems(1)
End With
PRDX_ChooseFile = True
End Function
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Трабл в том что именно надо это сделать с множества файлов. Но вот не задача, хз как реализовать считывание с ячейки и перенос на лист где макрос. И при эти данные добавлять в столбец, не удаляя прежние. Уже ломал голову и пробовал по разному. Результат вот что вышло, но с одним файлом увы. Следующий файл перезаписывает прежнее данные. А надо что бы именно добавило данные после первого файла. Как то так)
aosunproject написал: Следующий файл перезаписывает прежнее данные
Например:
Код
Sub record_1()
'...
With ThisWorkbook.Sheets(1)
SrcWbkSht.Range("C7", SrcWbkSht.Range("C7").End(xlDown)).Copy _
Destination:=.Range("F" & .Rows.Count).End(xlUp).Offset(1, 0)
Application.CutCopyMode = False
'...
End With
'...
End Sub
а почему бы не применять простое правило: у темы нет названия - тему в топку может люди когда-нибудь начнут писать в названии темы не о проблемах, с которыми столкнулись используя определенную функцию для решения задачи, а будут писать о задаче, которую не могут решить
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Нужно что бы данные добавили следующие строки после первых. То есть как на рисунке, там где помечено должно добавить следующие данные. И так столько нужно будет. В идеале нужно было реализовать что бы с выбранных файлов вытягивало например столбец "С" и до последней включно заполненной ячейки(кроме пустых). И скопировать это туда где мне надо и вставить(проверяя где последняя заполненная ячейка и вставлять после). Аналогично сделать с полем "В" и "А". При этом что бы данные были друг на против друга. Так как вытягиваются отдельные поля, а не вся книга.
Если это вычислить 1 раз и записать в переменную, то все последующие вставки попадут в 1 строку, а если это пересчитывать после каждой вставки, то (3 попытки для угадать).
RAN написал: Если это вычислить 1 раз и записать в переменную, то все последующие вставки попадут в 1 строку, а если это пересчитывать после каждой вставки, то (3 попытки для угадать).
Я не для того пишу, что бы угадывать. Суть проблемы описал. Вот спрашиваю у знатоков пример решения. Или дать решение в целом. Пока никто выше не дал толком ответ.
и получается так, что считает последнюю заполненную ячейку по всему листу. А не по конкретному полю. Итоге и не выходит. Мне нужно что бы счетчик каждый начинался отдельно. Вот и вся проблема)
нужно последняя заполненная строка по определенной колонке например а1, строка 5 последняя. В поле б1 строка 7
Итоги недели мучений вот решение:
Код
Set SrcWbk = Workbooks.Open(MasivWbs)
For i = 0 To N
N = DestWbk.Worksheets(1).Range("F1").End(xlDown).Row
i = N + 1
'MsgBox i
SrcWbk.Worksheets(1).Range("C7", Range("C7").End(xlDown)).Copy _
Destination:=DestWbk.Worksheets(1).Cells(i, 6)
Next i
For k = 0 To L
L = DestWbk.Worksheets(1).Range("E1").End(xlDown).Row
'MsgBox L
k = L + 1
' MsgBox i
SrcWbk.Worksheets(1).Range("D7", Range("D7").End(xlDown)).Copy _
Destination:=DestWbk.Worksheets(1).Cells(k, 5)
Next k
Тут момент с .End(xlDown).Row (Проверка последней ячейки). Может кому то надо будет. Теперь осталось разобраться как залить несколько файлов и что бы с них сразу свело в одну таблицу)
aosunproject, пока нет ответа на конкретную ситуацию: если на листе заполнены ячейки а1, в1, с1, д1, е1 а2 какая последняя заполненная на этом листе ячейка? не возможно
Цитата
aosunproject написал: определить последнюю ячейку на листе через VBA?
т.е. пока не понятно как вообще определяется последняя ячейка - не возможно определить последнюю ячейку с помощью VBA. просто хоть с VBA хоть без него не возможно определить последнюю ячейку, если не известно, как ее определять
aosunproject написал: Суть проблемы описал. Пока никто выше не дал толком ответ
Вам ответ дали на проблему еще в сообщении #3 от 13 Дек 2019 19:21:10. Там ссылки на статью, где разные методы определения последней ячейки расписаны, включая и упомянутый Вами .End(xlDown).Row с его достоинствами и недостатками. А вот Вы на задаваемые Вам вопросы отвечать не хотите. Отсюда и отсутствие решений конкретно под Вашу проблему.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, по названию темы один-в-один, жаль только все еще не понятно какую ячейку автор считает последней заполненной (может оказаться совсем не та, что в советах, и это автоматически делает совет совершенно бесполезным для решения задачи решаемой автором темы) т.е. когда понятны все условий задачи, ее бывает трудно решить, а когда условий нет - решение можно только угадать!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Я написал выше как мне надо в сообщении #23. Решение нашел, благодаря выводу в сообщении. Оттуда математика и результат. Чутка позже напишу полный код, может кому то поможет для подобных задач.