Скопируйте данные из нескольких файлов в один лист с инкрементными строками.
Я использую следующий код, чтобы открыть один из нескольких файлов, скопировать строку из рабочего листа и вставить его обратно в первый лист, а затем закрыть открытый файл.
Моя проблема в том, что я не могу пройти мимо функции, чтобы перемещаться по строкам каждый раз, когда она вставляет. Я хочу, чтобы он постепенно вставлял значения в новую строку, т. Е. B3 , затем B4 , затем B5 и т. Д.
Sub Auto_open_change() Dim WrkBook As Workbook Dim StrFileName As String Dim FileLocnStr As String Dim LAARNmeWrkbk As String PERNmeWrkbk = ThisWorkbook.Name FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path Dim StrFile As String StrFile = Dir(FileLocnStr & "\*.xls") Do While Len(StrFile) > 0 DoStuff (FileLocnStr & "\" & StrFile) StrFile = Dir Loop End Sub Private Sub DoStuff(StrFileName) Workbooks.Open (StrFileName) Call Edit Workbooks.Open (StrFileName) ActiveWorkbook.Close End Sub Sub Edit() Dim Wb1 As Workbook Dim ws1 As Worksheet Dim loopcal As Long With Application .ScreenUpdating = False .EnableEvents = False lngCalc = .Calculation End With Set Wb1 = ActiveWorkbook Sheets("1_3 Octave1 CH1").Select Range("A3:AH3").Select Selection.Copy Windows("template.xlsm").Activate Sheets("Data Extract").Select Range("B3").Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End Sub
- Выберите несколько ячеек из нескольких листов из нескольких файлов в Excel
- как вставлять данные с использованием последней строки в VBA excel
- Копирование и вставка Отфильтрованные строки в VBA
- Excel VBA Как скопировать и вставить раздел ячеек в новый лист
- Excel VBA Copy и Paste (без использования функций Copy + Paste) в пустой строке
- Неправильно скопировано Excel VBA
- Если ячейка в столбце имеет данные, тогда скопируйте и вставьте в другую ячейку в той же строке
- Excel VBA: копирование содержимого ячейки
- VBA - копирование и вставка из нескольких файлов Excel в один файл Excel
- Динамический mnacro сравнивает две таблицы и добавляет строку, если не найден на одной таблице, или обновляет информацию, если найденная строка, но какая-то информация отличается
- VBA - Цитирование всех листов диаграмм и копирование на один рабочий лист
- VBA Copy Вставить значения из отдельных диапазонов и вставить на один и тот же лист, одинаковые столбцы сдвига строки (повторить для нескольких листов)
- Найдите строку строкового значения в столбце, в то время как критерии удовлетворяются в той же строке, но в других столбцах
Вы можете попробовать следующее:
Sub GetData(Fname as String) Dim wb1, wb2 as Workbook Dim ws1, ws2 as Worksheet Dim lrow as Long Set wb1 = Thisworkbook Set ws1 = wb1.Sheets("DataExtract") Set wb2 = Worbooks.Open(Fname) Set ws2 = wb2.Sheets("1_3 Octave1 CH1") With ws1 lrow = .Range("B" & Rows.Count).End(xlUp).Row ws2.Range("A3:AH3").Copy .Range("B" & lrow).Offset(1,0).PasteSpecial xlPasteValues Application.CutCopyMode = False End With wb2.Close False End Sub
Просто замените DoStuff и Edit subs.
надеюсь это поможет.
Непроверенные:
Sub Auto_open_change() Dim StrFileName As String Dim FileLocnStr As String Dim fNum As Long Dim StrFile As String FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path With Application .ScreenUpdating = False .EnableEvents = False End With fNum = 1 StrFile = Dir(FileLocnStr & "\*.xls") Do While Len(StrFile) > 0 CopyData FileLocnStr & "\" & StrFile, fNum StrFile = Dir fNum = fNum + 1 Loop With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Sub CopyData(StrFileName As String, fNum As Long) Dim Wb1 As Workbook, rngCopy As Range Dim rngDest As Range Set Wb1 = Workbooks.Open(StrFileName) Set rngCopy = Wb1.Sheets("1_3 Octave1 CH1").Range("A3:AH3") Set rngDest = ThisWorkbook.Sheets("Data Extract") _ .Range("B2").Offset(fNum, 0) rngCopy.Copy rngDest With rngDest.Resize(rngCopy.Rows.Count, rngCopy.Columns.Count) .Value = .Value End With Wb1.Close False End Sub
Ну, с помощью кода, который вы используете, вы можете просто создать переменную в Lo While Loop, которая вызывает DoStuff и передать ее в подменю Edit, а затем постройте диапазон из этого.
Итак, в цикле Do While
rowcounter = 3 Do While Len(StrFile) > 0 DoStuff (FileLocnStr & "\" & StrFile, rowcounter) StrFile = Dir rowcounter = rowcounter + 1 Loop
Затем измените DoStuff
Private Sub DoStuff(StrFileName As String, rowcounter As Integer) Workbooks.Open (StrFileName) Call Edit(rowcounter) Workbooks.Open (StrFileName) ActiveWorkbook.Close End Sub
Затем измените Edit
Sub Edit(rowcounter As Integer) . . . . Windows("template.xlsm").Activate Sheets("Data Extract").Select Range("B" & rowcounter).Select . . End Sub
«Ребята, вот окончательное редактирование. отлично работает, спасибо за помощь и поддержку ребятам.
Option Explicit Sub Auto_open_change() Dim WrkBook As Workbook Dim StrFileName As String Dim FileLocnStr As String Dim LAARNmeWrkbk As String Dim rowcounter As Integer FileLocnStr = "T:\Projects\data" 'ThisWorkbook.Path Dim StrFile As String StrFile = Dir(FileLocnStr & "\*.xls") rowcounter = 3 Do While Len(StrFile) > 0 Call DoStuff(FileLocnStr & "\" & StrFile, rowcounter) StrFile = Dir rowcounter = rowcounter + 1 Loop End Sub Private Sub DoStuff(StrFileName As String, rowcounter As Integer) Workbooks.Open (StrFileName) Call Edit(rowcounter) Workbooks.Open (StrFileName) ActiveWorkbook.Close End Sub Sub Edit(rowcounter As Integer) Dim Wb1 As Workbook Dim ws1 As Worksheet Dim loopcal As Long With Application .ScreenUpdating = True .EnableEvents = True lngCalc = .Calculation End With Set Wb1 = ActiveWorkbook Sheets("1_3 Octave1 CH1").Select Range("A3:AH3").Select Selection.Copy Windows("template.xlsm").Activate Sheets("Data Extract").Select Range("B" & rowcounter).Select 'index the variable to ensure the cell reference changes each time. Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End Sub