Выбор поля в макросе и вырезание его в цикле

Мне нужно выбрать поле ячеек (таблицы) на листе Excel, вырезать выделение, а затем вставить его в новый отдельный лист. В этом листе таблички ниже, чем тысячи, и я хочу, чтобы они автоматически вырезали их и вставляли их в отдельные листы. Таблицы разделены ячейками с # символом внутри, но я не знаю, насколько это полезно в любом случае. Когда я записал этот макрос для первой таблицы, он работает следующим образом:

Sub Makro1() Range("A2:AB20").Select Selection.Cut Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Paste End Sub 

Теперь я хочу сделать цикл, который будет проходить через весь рабочий лист, динамически выбирать каждую таблицу, которая будет ограничена знаком # в столбце A и вставить его в новый лист. Я не хочу выбирать точный диапазон A2: AB20, но я хочу сделать выбор в соответствии с этим знаком #.

Вот скриншот введите описание изображения здесь

Попробуйте этот код. Возможно, вам потребуется настроить верхние 4 константы в соответствии с вашими потребностями:

 Sub CopyToSheets() Const cStrSourceSheet As String = "tabulky" Const cStrStartAddress As String = "A2" Const cStrSheetNamePrefix As String = "Result" Const cStrDivider As String = "#" Dim rngSource As Range Dim lngMaxRow As Long, lngLastDividerRow As Long, lngRowCount As Long Dim wsTarget As Worksheet Dim lngCounter As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'Delete old worksheets Application.DisplayAlerts = False For Each wsTarget In Sheets If InStr(wsTarget.Name, cStrSheetNamePrefix) Then wsTarget.Delete Next Application.DisplayAlerts = True With Sheets(cStrSourceSheet) Set rngSource = .Range(cStrStartAddress) lngLastDividerRow = rngSource.Row lngMaxRow = .Cells(Rows.Count, 1).End(xlUp).Row End With Set rngSource = rngSource.Offset(1) While rngSource.Row < lngMaxRow If rngSource = cStrDivider Then lngCounter = lngCounter + 1 Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count)) wsTarget.Name = cStrSheetNamePrefix & " " & lngCounter lngRowCount = rngSource.Row - lngLastDividerRow - 1 rngSource.Offset(-lngRowCount - 1).Resize(lngRowCount).EntireRow.Copy _ wsTarget.Range("A1").Resize(lngRowCount).EntireRow lngLastDividerRow = rngSource.Row End If Set rngSource = rngSource.Offset(1) Wend Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub 

Это заполнит массив указателями всех ваших хэш-значений. Это должно предоставить вам ориентир, необходимый для сбора соответствующих данных.

 Sub FindHashmarksInColumnA() Dim c As Range Dim indices() As Long Dim i As Long Dim iMax As Double Dim ws As Worksheet Set ws = ActiveSheet i = 0 iMax = Application.WorksheetFunction.CountIf(ws.Range("A:A"), "#") ReDim indices(1 To iMax) For Each c In ws.UsedRange.Columns(1).Cells If c.Value = "#" Then i = i + 1 indices(i) = c.Row End If Next c ' For each index, ' Count rows in table, ' Copy data offset from reference of hashmark, ' Paste onto new sheet in appropriate location etc. End Sub 
Interesting Posts

Таблица в столбце Excel

Поиск диапазона из разных столбцов и вставка значения

Использование InStr для сравнения двух столбцов

индекс и длина должны ссылаться на местоположение внутри строки vb

Как экспортировать ежедневное использование дискового пространства?

строить файлы xls в R с заголовком поверх имен столбцов

Как построить столбец, используя данные из другой таблицы с ограничениями

Python openpyxl load_workbook Ошибки: TypeError (NoneType not Iterable) и ValueError (максимальное значение – 180)

SUMIF с кодом зоны телефона и подстановочным знаком *, являющимся критерием

Python xlsxwriter – добавьте рабочий лист в существующую книгу

Значение Vba задано в столбце, если значения совпадают и полученные ордеры?

Библиотека типа Excel / Delphi 2009 / тип плохой переменной

Можно ли автоматически восстанавливать поврежденные книги Excel?

Пересечение линии – с разницей (excel VBA)

Excel: добавьте номер перед умножением на PRODUCT (…)

Давайте будем гением компьютера.