How to copy a range from sheet to other sheets?-CodePudding

I'm trying to create a macro that copies a certain range (CA1:CZ99) from "Sheet A" to lots of other sheets. The names of the other sheets are based on a value of column F in "Sheet B".

The code for copying the data is easy to find.

Worksheets("Sheet A").Range("CA1:CZ99").Copy Worksheets("Sheet X").Range("CA1")

But how do I loop this part over all the sheets from column F?

CodePudding user response：

Specify exactly where to get the data from as a variable, and then loop over it. Example:

Sub loopCopy()
Dim shtRng As Range
Dim c As Variant
Set shtRng = Worksheets("Sheet B").Range("F1:F5")
For Each c In shtRng
    Worksheets("Sheet A").Range("CA1:CZ99").Copy Worksheets(c.Value).Range("CA1")
Next c
End Sub

This is a very basic setup. If the value from the column doesn't match a sheet, or if "Sheet A" or "Sheet B" change names, it will crash.
You might want to have the list adjust in size dynamically by finding last row, etc.

CodePudding user response：

Copy a Range to Multiple Worksheets

Option Explicit

Sub CopyRange()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet A")
    Dim srg As Range: Set srg = sws.Range("CA1:CZ99")
    
    ' Lookup
    Dim lws As Worksheet: Set lws = wb.Worksheets("Sheet B")
    Dim lfRow As Long: lfRow = 2
    Dim llRow As Long: llRow = lws.Cells(lws.Rows.Count, "F").End(xlUp).Row
    If llRow < lfRow Then Exit Sub ' no data
    Dim lrg As Range: Set lrg = lws.Cells(lfRow, "F").Resize(llRow - lfRow   1)

    ' Copy to Destination
    Dim dws As Worksheet
    Dim lCell As Range
    Dim lCount As Long
    For Each lCell In lrg.Cells
        On Error Resume Next ' check if the worksheet exists
            Set dws = wb.Worksheets(CStr(lCell.Value))
        On Error GoTo 0
        If Not dws Is Nothing Then ' the worksheet exists
            lCount = lCount   1
            srg.Copy dws.Range("CA1")
            Set dws = Nothing
        'Else ' the worksheet doesn't exist
        End If
    Next lCell
    
    ' Inform
    MsgBox "Range copied to " & lCount & " worksheets.", _
        vbInformation, "CopyRange"

End Sub