Как скопировать диапазон на несколько листов, используя список листов для копирования

Поместите этот код в первый модуль кода листа (где находятся данные). Диапазоны жестко запрограммированы, поэтому об этом следует помнить. Например. если листов меньше 10, будет ошибка в отсутствующих именах, а если больше 10, листы больше 10 будут исключены. «A1:A10» может измениться на указанный диапазон.

Sub mulcopy()

Range("A1:A10").Copy
For i = 1 To 10
  shnames = Cells(i, "B")
  Application.Worksheets(shnames).Range("C1").PasteSpecial xlPasteAll
Next i


End Sub

Мой пример ниже показывает несколько вещей, которые могут помочь, особенно когда вы только начинаете работать с VBA.

1. Используйте описательные имена для своих переменных и будьте максимально ясными.
2. Вам не обязательно использовать Select для копирования/вставки. Просто скопируйте диапазон в диапазон.
3. Я добавил функцию для проверки правописания на листе, потому что это наверняка может сбить вас с толку при попытке отладки.

Option Explicit

Sub CopyCitiesToSheets()
    Dim srcWS As Worksheet
    Set srcWS = ThisWorkbook.Sheets("Source Sheet")
    
    Dim cities As Range
    Set cities = srcWS.Range("CITIES")
    
    '--- does not assume that you have the same number of rows
    Dim destSheetNames As Range
    With srcWS
        Dim lastRow As Long
        lastRow = .Range("CITIES").Offset(0, 1).Cells(.Rows.Count, 1).End(xlUp).Row
        Set destSheetNames = srcWS.Range("CITIES").Offset(0, 1).Resize(lastRow, 1)
    End With
    
    Dim destSheetName As Variant
    For Each destSheetName In destSheetNames
        '--- establish where the cities are going, but sure to match the same
        '    size and shape of the source range
        Dim destination As Range
        Set destination = GetDestinationRange(destSheetName, cities.Rows.Count, cities.Columns.Count)
        destination.Value = cities.Value
    Next destSheetName
    
End Sub

Function GetDestinationRange(ByVal destSheetName As String, _
                             ByVal numRows As Long, _
                             ByVal numCols As Long) As Range
    Dim dstWS As Worksheet
    On Error Resume Next
    Set dstWS = ThisWorkbook.Sheets(destSheetName)
    If Err <> 0 Then
        MsgBox "ERROR: not a value worksheet name!  Did you misspell it?", _
               Buttons:=vbCritical + vbOKOnly, _
               Title: = "ERROR in Worksheet Name"
    End If
    Set GetDestinationRange = dstWS.Range("C1").Resize(numRows, numCols)
End Function

Поздний пост с демонстрацией малоизвестного метода FillAcrossSheets.

Он копирует

• заданный диапазон на листе Sheet1 (например, ячейки A1:A10)
• в заданный целевой диапазон (например, ячейки C1:C10)
• во все листы, предварительно определенные в соседних ячейках (здесь: B1:B10):

Пример звонка

Option Explicit               ' (code module head)

Sub ExampleCall()
'0) base definitions
    With Sheet1.Range("CITIES")       ' << Change sheet reference as needed
        Dim cities:   cities = .Value2
        Dim mySheets: mySheets = getSheets(.Offset(0, 1))
        If UBound(mySheets) = -1 Then Exit Sub
    End With
'1) set target range in first sheet of chosen worksheets
    Dim tgtRng As Range
    Set tgtRng = ThisWorkbook.Worksheets(mySheets(1)).Range("C1").Resize(UBound(cities), 1)
'2) write cities to target range in chosen worksheets
    FillSheets tgtRng, cities, mySheets    ' << main procedure FillSheets
End Sub

Основная процедура FillSheets

Sub FillSheets(rng As Range, data, Optional SheetsArr)
'Purp: write data to all sheets included in argument SheetsArr
'Note: c.f. https://stackoverflow.com/questions/58879621/how-to-write-identical-information-in-a-specific-cell-for-all-sheets/58884112#58884112
'      c.f. https://learn.microsoft.com/en-us/office/vba/api/excel.sheets.fillacrosssheets
'a) fill the range in the first target sheet
    rng = data
'b) write data via Excel method FillAcrossSheets
    If IsMissing(SheetsArr) Then    ' fill all sheets
        Sheets().FillAcrossSheets rng
    Else                            ' fill only target sheets
        If UBound(SheetsArr) - LBound(SheetsArr) Then
            Sheets(SheetsArr).FillAcrossSheets rng
        End If
    End If
End Sub

Вспомогательная функция getSheets (по сравнению с MS365)

Function getSheets(rng As Range)
'Purp:  assign sheet names to 1D array ignoring empty cells
'Note:  needs vers. MS365 !
    Dim addr As String: addr = rng.Address(external:=True)
    getSheets = Evaluate("Transpose(Filter(" & addr & "," & addr & "<>0))")
End Function

GetSheets() для более ранних версий

Если вы не избавитесь от vers. MS 365, чтобы получить имена листов, вы можете попробовать следующий код:

Function getSheets(rng As Range)
'Purp:  assign sheet names to 1D array and omit empty names
'a) assign values to 1D array
    Dim tmp: tmp = Application.Transpose(rng.Value2)
'b) omit empty sheet names
    Dim i As Long, ii As Long
    For i = 1 To UBound(tmp)
        If Len(Trim(tmp(i))) Then
            ii = ii + 1: tmp(ii) = tmp(i)
        End If
    Next i
    If ii Then
        ReDim Preserve tmp(1 To ii)
    Else
        tmp = Array()
    End If
'c) return function result
    getSheets = tmp
End Function