如何复制&；使用VBA将数据值粘贴到不同的工作表中

我正在尝试从工作簿1复制数据，并根据这些阀粘贴到工作簿2，如果阀与上一个不同，则在工作簿中创建一个新工作表，并开始在新工作表中粘贴阀，直到在工作簿1中未找到空行为止

Sub icopy()

Dim LastRow As Long, Limit2 As Long, c As Long, d As Long, erow As Long
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, wb As Workbook, 
wb1 As Workbook

If Is_WorkBook_Open("test.xlsx") Then
    Set wb = Workbooks("test.xlsx")
Else
    Set wb = Workbooks.Open("D:\Data\test.xlsx")
End If

Set sh1 = wb.Sheets("Sheet1")
LastRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row
'wb.Close

MsgBox LastRow

For i = 2 To LastRow
    If sh1.Cells(i, 1) = sh1.Cells(i + 1, 1) Then
        If (i = 2) Then
        Set wb1 = Workbooks.Open("D:\Data\Data1.xlsx")
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = sh1.Cells(2, 1)
        Set sh2 = wb1.ActiveSheet.Name
    End If
    sh1.Range(Cells(i, 1), Cells(i, 3)).Copy
    erow = sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    'sh2.Cells(erow, 1).Select
    sh2.Cells(erow, 3).Paste
    sh2.Paste
    ActiveWorkbook.Save
Else
    MsgBox i
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sh1.Cells(i + 1, 1)
End If

Next i
    'erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    'ActiveSheet.Cells(erow, 1).Select
    ' ActiveSheet.Paste
    'ActiveWorkbook.Save
    'ActiveWorkbook.Close
    'Application.CutCopyMode = False
End Sub

Function Is_WorkBook_Open(ByVal strWorkbookName As String) As Boolean
Dim wb As Workbook

On Error Resume Next
Set wb = Workbooks(strWorkbookName)
   If Err Then
   Is_WorkBook_Open = False
Else
   Is_WorkBook_Open = True
End If

End Function

---

因为我知道你的阀门数据是相邻的（即所有相同的阀门数据都在相邻的一个街区内），你可以考虑以下内容：

Option Explicit

Sub icopy()
    Dim sh1 As Worksheet, sh2 As Worksheet, wb1 As Workbook
    Dim iRow As Long

    If Is_WorkBook_Open("test.xlsx") Then
        Set sh1 = Workbooks("test.xlsx").Sheets("Sheet1")
    Else
        Set sh1 = Workbooks.Open("D:\Data\test.xlsx").Sheets("Sheet1")
    End If

    Set wb1 = Workbooks.Open("D:\Data\Data1.xlsx") ' open your target workbook
    With sh1
        iRow = 2
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            Do While iRow <= .Rows.Count
                .AutoFilter field:=1, Criteria1:=.Cells(iRow, 1).Value
                wb1.Sheets.Add(After:=wb1.Sheets(wb1.Sheets.Count)).name = .Cells(iRow, 1).Text
                With .Resize(, 3).SpecialCells(xlCellTypeVisible)
                    .copy Destination:=wb1.Sheets(.Cells(iRow, 1).Text).Range("a1")
                    iRow = .Areas(.Areas.Count).Rows(.Areas(.Areas.Count).Rows.Count).row + 1
                End With
            Loop
        End With
        .AutoFilterMode = False
    End With
End Sub 

选项显式
子icopy（）
尺寸sh1作为工作表，sh2作为工作表，wb1作为工作簿
暗淡无光
如果工作簿处于打开状态（“test.xlsx”），则
Set sh1=工作手册（“test.xlsx”）.工作表（“Sheet1”）
其他的
设置sh1=Workbooks.Open（“D:\Data\test.xlsx”）.Sheets（“Sheet1”）
如果结束
设置wb1=Workbooks.Open（“D:\Data\Data1.xlsx”）'打开目标工作簿
与sh1
iRow=2
带.Range（“A1”，.Cells（.Rows.Count，1）.End（xlUp））
你可能想添加一些前后场景的屏幕截图，但现在不行，这对我来说已经足够了：）我不明白，我正试图将数据从一个工作簿复制到另一个工作簿。因此，数据就像设备的每个条目一样，按日期排列。有3000多台设备。如果每个设备都有单独的工作表，那么进一步的工作就更好了。首先，您要过滤数据，然后复制到目标工作表，但问题是，当I代码运行时，当irow为2时，表示脚本超出范围。这意味着在我的理解中存在一些问题，我想告诉我我做错了什么{.copy Destination:=wb1.Sheets（.Cells（iRow，1.Value）.Range（“a1”）}不幸的是，如果看不到您的数据布局，很难帮助您解决类似的问题。我不会从web上打开任何文件。添加一些相关的屏幕截图