Excel 将特定范围复制到所有图纸_Excel_Vba

Excel 将特定范围复制到所有图纸

excel vba

Excel 将特定范围复制到所有图纸,excel,vba,Excel,Vba,我写了这段代码，但是我很难让它正常工作。我不想把C2:D5看作是10个项目的范围，而是想把C2和单元格D2看作一个项目，以此类推。这份清单基本上由五项组成，而不是十项。然后将其复制到相应的单元格D3:E3，如下所示。用vba也可以吗 Dim wb As Workbook Set wb = ThisWorkbook Dim startsheet As Worksheet Set startsheet = wb.Sheets("start") Dim r As Range

我写了这段代码，但是我很难让它正常工作。我不想把C2:D5看作是10个项目的范围，而是想把C2和单元格D2看作一个项目，以此类推。这份清单基本上由五项组成，而不是十项。然后将其复制到相应的单元格D3:E3，如下所示。用vba也可以吗


Dim wb As Workbook
Set wb = ThisWorkbook

Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")

Dim r As Range
Set r = startsheet.Range("C2:D5") '

Dim sh As Worksheet

For Each sh In Worksheets
     For i = 1 To r.Count
   If Not i + 1 > Worksheets.Count Then Worksheets(i + 1).Range("D3:E3").Value = r.Item(i,1).Value
      
     Next i
Next sh


End Sub   ```

我将再次使用

copy

方法，但是我将假设复制表是

sheet1

，并且您已经为函数创建了

sheet2-5

，请尝试查看并修改if语句，以防出现其他问题：

Sub test2()

Dim wb As Workbook
Dim i As Long

Set wb = ThisWorkbook

Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")


For i = 2 To ThisWorkbook.Worksheets.Count
    startsheet.Range("C" & i, "D" & i).Copy Worksheets(i).Range("D3")
Next

End Sub

代码中的问题是，当您只需要一个循环时，您使用了两个循环。工作表的循环是不必要的，因为您已经在代码为“Worksheets（i+1）.Range（“D3”）.Value”的工作表中循环

结束子项

是的，如果在开始表的C列中添加更多项目，则可以轻松修改代码以添加工作表。就像这样：

Sub TEST()
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim i As Long, LastRow As Long

Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")
LastRow = startsheet.Range("C2:C" & Rows.Count).End(xlDown).Row

Dim r As Range
startsheet.Activate
Set r = startsheet.Range(Cells(2, 3), Cells(LastRow, 3))

Dim sh As Worksheet

For i = 1 To r.Rows.Count
    If i + 1 > wb.Worksheets.Count Then
        Set sh = wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        Worksheets(i + 1).Range("D3").Value = r.Item(i, 1).Value
        Worksheets(i + 1).Range("E3").Value = r.Item(i, 2).Value
    Else
        Worksheets(i + 1).Range("D3").Value = r.Item(i, 1).Value
        Worksheets(i + 1).Range("E3").Value = r.Item(i, 2).Value
    End If
Next i

结束子项

将每一行复制到下一张工作表

如果选择使用
```
.worksheets（1）
```
，请删除
```
swsName
```
常量
使用其余三个常量的值

子CopyRowsForNext（）
Const swsName As String=“start”
Const srgAddress As String=“C2:D5”
Const dFirst As String=“D3”'第一个目标单元格
Const wsFirst长度=2'第一个目标工作表
将wb设置为工作簿：设置wb=ThisWorkbook
将wsCount调整为长：wsCount=wb.Worksheets.Count
如果wsCount=0，则退出Sub
将sws标注为工作表：设置sws=wb.工作表（swsName）
'也许这更合适（忘记“开始”）：
“将sws设置为工作表：设置sws=wb。工作表（1）
尺寸srg As范围：设置srg=sws范围（srg）
将srCount变长：srCount=srg.Rows.Count
将scCount变长：scCount=srg.Columns.Count
黯淡的辛迪克斯一样长
变暗，变长
对于r=1到srCount
cIndex=r+wsFirst-1
如果cIndex是可能的，但我无法理解您的观点您的目标是实现什么…我的目标是复制列表中每一行的单元格C2和D2（客户名称和id），然后是C3和D3等的值，从下一张工作表复制到单元格D3和E3，直到列表上的所有项目都被复制。是否要将源范围的每一行（C2:D5
）复制到从开始的下一张工作表的同一行目标范围（C3:D3
）。工作表（2）
？是.Worksheets（“开始”）
实际上是.Worksheets（1）？开始表实际上是工作表（1）。第一张表列出了所有客户的姓名，其余的表采用申请表的格式。这就是为什么我想用相同的格式复制其他工作表中的一个（但不是第一个）。您发送给我的代码工作正常，但如果我向列表中添加更多项，则创建的新工作表将为空@VBASIC208此代码将整个列表复制到所有其他工作表，而我希望将列表的第一项复制到第二个工作表，将列表的第二项复制到第三个工作表，依此类推。我已修改了代码，它应该足以解决您的问题？这工作完美无瑕。事实上，此功能的工作表已经创建。是否可以创建一个检查以查看是否没有可用的工作表（列表中有更多项目，但没有足够的工作表）？在这种情况下，代码可以复制以前的工作表之一吗？这会让代码变得“防弹”，还是会让代码变得太复杂@kin Siang当然可以，我已经修改了答案，如果行数超过工作表的总计数，它将停止复制…@steven:你能解释一下，在这种情况下，代码可以复制以前的工作表吗？这非常有效。非常感谢。这运行得非常好。非常感谢你。
Sub TEST()
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim i As Long, LastRow As Long

Dim startsheet As Worksheet
Set startsheet = wb.Sheets("start")
LastRow = startsheet.Range("C2:C" & Rows.Count).End(xlDown).Row

Dim r As Range
startsheet.Activate
Set r = startsheet.Range(Cells(2, 3), Cells(LastRow, 3))

Dim sh As Worksheet

For i = 1 To r.Rows.Count
    If i + 1 > wb.Worksheets.Count Then
        Set sh = wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        Worksheets(i + 1).Range("D3").Value = r.Item(i, 1).Value
        Worksheets(i + 1).Range("E3").Value = r.Item(i, 2).Value
    Else
        Worksheets(i + 1).Range("D3").Value = r.Item(i, 1).Value
        Worksheets(i + 1).Range("E3").Value = r.Item(i, 2).Value
    End If
Next i