Question

我需要帮助编辑我的代码，以便它执行更具体的操作。当前，代码使用“机会名称”列将所有数据从“数据”工作表中分离出来，以分隔相应的工作表。我需要它，以便根据用户希望它分开的地方分开。因此，例如，在名为“ Diagram”的单独工作表上的字段W11中，用户可以输入“ Co”作为机会，并且当他们单击同一工作表上的“ Split Data”按钮时，应仅按“ Co”进行分割并将其放入在名为“机会”的单独工作表中

这是我要实现的方案：

用户在W11字段的“图表”工作表中输入机会名称
用户在“图表”工作表中按下“拆分数据”按钮
自动创建一个单独的工作表，称为“机会”
查找“数据”工作表中的“机会名称”列，并将其与用户条目进行比较（步骤1）
与用户输入的字段（步骤1）相对应的所有数据将被复制到新创建的“机会”工作表中–包括整行（该特定条目的所有4列AD）。

示例：如果用户在W11字段中输入“ Co”，然后按“拆分数据”，则所有“ Co”机会都将放在单独的工作表中（称为“机会”）

Data Worksheet

Diagram Worksheet

假设：

用户可以再次按下“拆分数据”按钮，它应该重新执行该过程（覆盖“机会”工作表）
由于“数据”工作表上的数据将一直增加，因此查找范围应在行尾

我做了什么

如上所述，我正在努力使代码更加具体（不确定如何进行代码编辑-无法在线找到任何有助于我理解的内容）。我目前能够将所有数据拆分到不同的工作表中，但是我只需要根据用户的需求进行拆分即可。这是我下面的代码：

Private Sub CommandButton2_Click()

Const col = "A"
Const header_row = 1
Const starting_row = 2
Dim source_sheet As Worksheet
Dim destination_sheet As Worksheet
Dim source_row As Long
Dim last_row As Long
Dim destination_row As Long
Dim Opp As String

Set source_sheet = Workbooks("CobhamMappingTool").Worksheets("Data")
last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row

For source_row = starting_row To last_row
    Opp = source_sheet.Cells(source_row, col).Value
    Set destination_sheet = Nothing
    On Error Resume Next
    Set destination_sheet = Worksheets(Opp)
    On Error GoTo 0
    If destination_sheet Is Nothing Then 
        Set destination_sheet=Worksheets.Add(after:=Worksheets(Worksheets.Count))
        destination_sheet.Name = Opp
        source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
    End If
    destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1
    source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
Next source_row

End Sub

感谢您的帮助

非常感谢，詹姆斯

Answer 1

有多种方法可以实现您想要的。下面分享了使用大部分代码的代码。注意我添加的新行。

Private Sub CommandButton2_Click()

Const col = "A"
Const header_row = 1
Const starting_row = 2
Dim source_sheet As Worksheet
Dim destination_sheet As Worksheet
Dim source_row As Long
Dim last_row As Long
Dim destination_row As Long
Dim Opp As String

Dim oppVal As String

Set source_sheet = ThisWorkbook.Worksheets("Sheet3")
last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row

oppVal = Sheets("Diagram").Range("W11").Value


For source_row = starting_row To last_row
    Opp = "Opportunity"
    'source_sheet.Cells(source_row, col).Value

    Set destination_sheet = Nothing
    On Error Resume Next
    Set destination_sheet = Worksheets(Opp)
    On Error GoTo 0
    If destination_sheet Is Nothing Then
        Set destination_sheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        destination_sheet.Name = Opp
        source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
    End If
    destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1

    If source_sheet.Range("A" & source_row).Value = oppVal Then
        source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
    End If
Next source_row

End Sub

您会注意到： 1.正在oppVal变量中读取用户指定的值。 2.目标工作表名称始终为“机会” 3.代码检查A列中的值是否等于oppVal，然后将其复制到目标表中。

代码可以完成工作，但是，您可以做一些增强： 1.每次运行前清除目标表中的数据 2.使用过滤器选择行而不是循环，然后复制粘贴选定的行。

Answer 2

如果您已有工作表“机会”，则下面的代码将清除该工作表，然后使用“图表”工作表上W11中的值过滤“数据”工作表的A列，并一次性复制该范围，而不是复制行按行：

Private Sub CommandButton2_Click()
Dim wsSource As Worksheet: Set wsSource = Workbooks("CobhamMappingTool").Worksheets("Data")
Dim wsDiagram As Worksheet: Set wsDiagram = ThisWorkbook.Worksheets("Diagram")
Dim wsDestination As Worksheet: Set wsDestination = ThisWorkbook.Worksheets("Opportunity")
'declare and set worksheets
Dim LastRow As Long
Dim FoundVal As Variant

wsDestination.Cells.ClearContents
'clear the contents of workhsheet "Opportunity"
LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'get the last row with data on the data worksheet

Set FoundVal = wsSource.Range("A:A").Find(What:=wsDiagram.Range("W11"), Lookat:=xlWhole)
'check if value exists in Column A
    If Not FoundVal Is Nothing Then
    'if it does exist, then
        wsSource.Range("$A$1:$D$" & LastRow).AutoFilter Field:=1, Criteria1:=wsDiagram.Range("W11")
        'filter column A with the desired value
        wsSource.Range("A1:D" & LastRow).Copy Destination:=wsDestination.Range("A1")
        'copy the range into the Opportunity worksheet.
        wsSource.Range("$A$1:$D$" & LastRow).AutoFilter
        'remove autofilter
    End If
End Sub

如何使用VBA将特定数据从一个工作表复制到另一个工作表

2 个答案: