Excel Macro L oop Диапазон

Question

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

В сводной таблице (диапазон H2: H21) рабочей книги у меня есть список идентификационных номеров, которые я вручную вставил в E3 перед запуском макроса.

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

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

Может кто-нибудь показать, что мне нужно это делать?

Sub CreateNewSheet()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    With Workbooks("Batsmen.xlsx").Worksheets.Add()
    .Name = ThisWorkbook.Worksheets("Summary").Range("E3").Value
    End With

    With ThisWorkbook.Worksheets("Summary").Range("A22:J63").Copy
    Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
    Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteFormats
    Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    Workbooks("Batsmen.xlsx").Sheets(1).Range("A:J").Font.Size = 10
    End With

    With ThisWorkbook.Worksheets("Summary").Range("A22:J27").Copy
    With Workbooks("Batsmen.xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(2)
    .PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteFormats
    .PasteSpecial Paste:=xlPasteColumnWidths
    .Font.Size = 10
    End With
    End With

    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

Answer 1

Приведенный ниже код должен ответить на ваш вопрос, потому что он создает нужные вам листы.

Sub CreateNewSheet()

Dim Wb As Workbook
Dim WbBat As Workbook
Dim WsSum As Worksheet
Dim NamesRange As Range
Dim i As Integer
Dim TabName As String

With Application
    .ScreenUpdating = False
    .Calculation = xlManual
End With

Set Wb = ThisWorkbook
Set WbBat = Workbooks("Batsmen.xlsx")
Set WsSum = Wb.Worksheets("Summary")
Set NamesRange = WsSum.Range("H2:H21")

For i = 1 To NamesRange.Cells.Count
    TabName = Trim(NamesRange.Cells(i).Value)
    If Len(TabName) Then                    ' skip if name is blank
        With WbBat.Worksheets.Add()
            .Name = TabName
            WsSum.Range("A22:J63").Copy Destination:=.Cells(1, "A")
            WsSum.Range("A22:J27").Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(2)
            .Range("A:J").Columns.AutoFit
            .Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Font.Size = 10
        End With
    End If
Next i

With Application
    .Calculation = xlAutomatic
    .ScreenUpdating = True
End With

End Sub

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

Answer 2

Это можно оптимизировать, но вам следует начать.

Проверьте комментарии кода и настройте его в соответствии со своими потребностями.

Вы можете поместить курсоры в процедуру Process, нажмите клавишу F8 и посмотрите, что делает код.

РЕДАКТИРОВАТЬ: Добавлено summarySheet.Range("E3").value = cell.value в l oop

Option Explicit

Public Sub Process()

    Dim targetWorkbook As Workbook
    Dim summarySheet As Worksheet
    Dim sourceRange As Range
    Dim cell As Range

    ' Customize this settings
    Set targetWorkbook = Workbooks("Batsmen.xlsx")
    Set summarySheet = ThisWorkbook.Worksheets("Summary")
    Set sourceRange = summarySheet.Range("H2:H21")

    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    ' Loop through each cell in source range
    For Each cell In sourceRange.Cells
        ' Validate that cell has a value
        If cell.Value <> vbNullString Then

            ' Fill E3 with cell value from range in column H
            summarySheet.Range("E3").value = cell.value

            ' Execute procedure to create new sheet
            CreateNewSheet targetWorkbook, cell.Value, summarySheet
        End If
    Next cell

    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

Private Sub CreateNewSheet(ByVal targetWorkbook As Workbook, ByVal newSheetName As String, ByVal summarySheet As Worksheet)

    Dim targetSheet As Worksheet

    Set targetSheet = targetWorkbook.Worksheets.Add
    targetSheet.Name = newSheetName

    summarySheet.Range("A22:J63").Copy
    With targetSheet
        .Range("A1").PasteSpecial Paste:=xlPasteValues
        .Range("A1").PasteSpecial Paste:=xlPasteFormats
        .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        .Range("A:J").Font.Size = 10
    End With

    summarySheet.Range("A22:J27").Copy
    With targetSheet.Range("A" & Rows.Count).End(xlUp).Offset(2)
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
        .Font.Size = 10
    End With

End Sub

Дайте мне знать, если это работы