For...Next statement Range

Question

I want to copy a range between sheets using for..next, I have working loop, I don't know how to define a range that will change for each x in my loop, the range should be cells to the right of x in columns B and C.

Sub macro_cpt()
Dim Wiazka As String
Application.ScreenUpdating = False
Set w = Sheets("data_test")
w.Select
ActiveSheet.AutoFilterMode = False
owx = Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To owx Step 3
    Wiazka = Cells(x, "A")
    If Not SheetExists(ActiveWorkbook, Wiazka) Then
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Wiazka
    Else
        Sheets(Wiazka).Cells.ClearContents
    End If
    w.Select
    ????? Range ?????.Copy Sheets(Wiazka).Range("A1")
Next
Set W = Nothing
i = MsgBox("done.", vbInformation)
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
ActiveWorkbook.Close SaveChanges:=False
End Sub

Function SheetExists(Wb As Workbook, ShName As String) As Boolean
For Each s In Wb.Sheets
    If s.Name = ShName Then
        SheetExists = True
        Exit Function
    End If
Next
End Function

Try `w.Range(w.Cells(x,2),w.Cells(x,3)).Copy`? You are also encouraged to read on [how to avoid using Select/Activate](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) and fully qualify your range reference to avoid VBA assuming that you are referring to `ActiveSheet`/`ActiveWorkbook` — Raymond Wu, Oct 06 '21 at 10:17
Is the code located in a standard module in the `ActiveWorkbook`? Is worksheet `data_test` the first worksheet? Are you trying to copy each `B:C` from data_test to `A1:B1` in each destination worksheet? There is no need to set the `AutoFilterMode` a second time to `False`. Why are you doing all this when in the end you are closing the workbook without saving changes? Did you mean to use `SaveChanges:=True`? Please, share the additional information by [editing your post](https://stackoverflow.com/posts/69463335/edit) at any time. — VBasic2008, Oct 06 '21 at 11:22

score 0 · Answer 1 · answered Oct 06 '21 at 14:20

Copy to All Worksheets Except the First

In a worksheet (source) of the workbook containing this code (ThisWorkbook), in column A starting from the second row (A2), it will loop through each 3rd cell (containing a destination worksheet name) and copy the values from columns B:C in the current row, to cell A1 of each destination worksheet.

Option Explicit

Sub macro_cpt()
    
    ' Source
    Const sName As String = "data_test"
    Const sFirstRow As Long = 2
    Const sCol As String = "A" ' column of the destination worksheet names
    Const sStep As Long = 3 ' rows 2, 5, 8...
    Const sCols As String = "B:C" ' columns of data to be copied
    ' Destination
    Const dAddress As String = "A1"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Or:
    'Dim wb As Workbook: Set wb = ActiveWorkbook ' workbook you're looking at
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sLastRow As Long
    sLastRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
    Dim scrg As Range: Set scrg = sws.Columns(sCols) ' Source Column Range
    
    ' The source and destination row ranges have the same number of columns.
    Dim cCount As Long: cCount = scrg.Columns.Count
    
    Application.ScreenUpdating = False
    ActiveSheet.AutoFilterMode = False
    
    Dim srrg As Range ' Source Row Range
    Dim dws As Worksheet
    Dim drrg As Range ' Destination Row Range
    Dim dName As String
    Dim r As Long
    
    For r = sFirstRow To sLastRow Step sStep
        dName = sws.Cells(r, sCol)
        ' You don't want to (accidentally) write to the source worksheet.
        If StrComp(dName, sName, vbTextCompare) <> 0 Then
            If IsSheetNameTaken(wb, dName) Then ' all sheets, charts included
                Set dws = wb.Worksheets(dName) ' error if chart
                dws.Cells.ClearContents
            Else ' worksheet doesn't exist
                Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                dws.Name = dName
            End If
            Set srrg = scrg.Rows(r)
            Set drrg = dws.Range(dAddress).Resize(, cCount)
            ' Copy values only (most efficiently)
            drrg.Value = srrg.Value
            ' Copy values, formulas and formats.
            'srrg.Copy drrg
        'Else ' it's the source worksheet
        End If
    Next r
    
    sws.Activate
    'wb.Save ' uncomment after testing
    
    Application.ScreenUpdating = True
    
    MsgBox "Data distributed among worksheeets.", _
        vbInformation, "Distribute Data"
    
    'wb.Close ' uncomment after testing
    
End Sub

Function IsSheetNameTaken( _
    ByVal wb As Workbook, _
    ByVal SheetName As String) _
As Boolean
    On Error Resume Next
    Dim sh As Object: Set sh = wb.Worksheets(SheetName)
    On Error GoTo 0
    IsSheetNameTaken = Not sh Is Nothing
End Function

For...Next statement Range

1 Answers1

Copy to All Worksheets Except the First