Зацикливание копии на новую функцию книги на нескольких вкладках на основе названий вкладок в значениях ячеек

Я хочу скопировать данные с каждой вкладки в электронную таблицу и сохранить ее в качестве новых книг. В оригинальной книге есть много вкладок (около 50), и одна из этих вкладок настроена для макроса для запуска данных, так как в будущем могут быть добавлены новые вкладки. На вкладке данных макроса содержится местоположение файла для каждой новой рабочей книги, название вкладки, а также некоторая информация, используемая другим макросом, для отправки этих вновь созданных книг соответствующим лицам.

Проблема заключается в том, что макрос распознает имена вкладок для нахождения диапазона для копирования, поскольку имена вкладок перечислены в ячейке. Я не уверен, можно ли использовать этот список, или я добавлю листок в конец, чтобы перебрать все листы из указанного начального местоположения до тех пор, пока это не будет с if.

Sub Datacopy() Dim ws As Worksheet With Application .ScreenUpdating = False End With Application.DisplayAlerts = False Set ws = Sheets("email") For Each Cell In ws.Columns("B").Cells Dim file1 As String file1 = Cell.Offset(0, 3).Text Sheets("cell.value").Range("A1:L500").Copy Workbooks.Add.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme) Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteComments) ActiveWorkbook.SaveAs Filename:=file1 ActiveWorkbook.Close Next Cell Application.DisplayAlerts = True With Application .ScreenUpdating = True End With MsgBox ("Finished making files!") End Sub 

Что-то вроде этого должно работать на вас. Обратите внимание на следующее:

  • Код предполагает, что на листе «email» у него есть строка заголовка, которая является строкой 1, а фактические данные начинаются в строке 2.
  • Он проверяет, является ли ячейка столбца B допустимым именем рабочего листа в книге

Я проверил, что этот код работает правильно и как предполагалось на основе вашего исходного сообщения:

 Sub Datacopy() Dim wb As Workbook Dim wsData As Worksheet Dim wsTemp As Worksheet Dim rSheetNames As Range Dim rSheet As Range Set wb = ActiveWorkbook Set wsData = wb.Sheets("email") Set rSheetNames = wsData.Range("B2", wsData.Cells(Rows.Count, "B").End(xlUp)) If rSheetNames.Row < 2 Then Exit Sub 'No data With Application .ScreenUpdating = False .DisplayAlerts = False End With For Each rSheet In rSheetNames If Not Evaluate("ISERROR('" & rSheet.Text & "'!A1)") Then Set wsTemp = Sheets.Add Sheets(rSheet.Text).Range("A1:L500").Copy wsTemp.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme wsTemp.Range("A1").PasteSpecial xlPasteComments wsTemp.Move ActiveWorkbook.SaveAs rSheet.Offset(, 3).Text ActiveWorkbook.Close False End If Next rSheet With Application .ScreenUpdating = True .DisplayAlerts = True End With MsgBox "Finished making files!" End Sub 
  • Удалить дубликаты ячеек в excel через вкладки
  • Изменить вкладку Цвет последних 4 листов Excel в Excel (VBA)
  • Давайте будем гением компьютера.