对于..下一个语句范围

Question

我想使用for在工作表之间复制一个范围。。接下来，我有一个工作循环，我不知道如何定义循环中每个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