Question

我正在尝试将数据从workbook1复制并粘贴到workbook2，如果阀门与之前的阀门不同，而不是在工作簿中创建新工作表并在新工作表中开始粘贴阀门，直到找不到空白工作簿中的一行。

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

Answer 1

因为我知道您的阀门数据相邻（即所有相同的阀门数据都在相邻行的一个块内），您可以考虑以下事项：

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

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

1 个答案: