For...下一个语句范围

Question

我想使用 for..next 在工作表之间复制一个范围，我有工作循环，我不知道如何定义一个范围，该范围将在我的循环中为每个 x 更改，范围应该是右侧的单元格列 B 和 C 中的 x。

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

Answer 1

复制到除第一个以外的所有工作表

• 在包含此代码 (ThisWorkbook) 的工作簿的工作表（源）中，在从第二行 (A2) 开始的列 A 中，它将遍历每个第三个单元格（包含目标工作表名称) 并将当前行中B:C 列中的值复制到每个目标工作表的单元格A1。

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