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

Question

I need help editing my code so that it does something more specific. Currently the code separates all data from a "Data" worksheet in to separate corresponding worksheets using the "Name of Opportunity" column. I need it so that it separates depending on what the user wants it to separate by. So for example, in field W11 on a separate worksheet called "Diagram" the user can enter "Co" as a opportunity and when they click the "Split Data" button on the same worksheet it should only split by "Co" and put it in a separate worksheet called "Opportunity"

Here is the scenario I am trying to achieve:

1. User enters an opportunity name in the “Diagram” worksheet in field W11

2. User presses “Split Data” button in “Diagram” worksheet

3. A separate worksheet is automatically created called “Opportunity”

4. Looks-up the “Name of Opportunity” column in the “Data” worksheet and compares it with the user entry (step 1)

5. All the data that corresponds with the users entered field (step 1) will be copied over into the newly made “Opportunity” worksheet – This includes the entire row (all 4columns AD of that specific entry).

Example: If a user types in "Co" in the W11 field and then presses the "Split Data" - all the "Co" opportunities will be put in a separate worksheet (called "Opportunity")

Data Worksheet

Diagram Worksheet

Assumptions:

• The user can press the “Split Data” button again and it should re-do the process (Overwrite the “Opportunity” worksheet)

• As the data on the "Data" worksheet will be always increasing the range that it looks up should be end of row

What I have done

As stated above I am struggling to get the code to be more specific (unsure how to go about editing the code - can't find anything online that helps me understand). I am currently able to split all data into different worksheets but I need it only to be split by what the user wants. Here is the code I have below:

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

Any help is appreciated

Many thanks, James

Answer 1

There are more than one ways to achieve what you are looking for. The one which uses most of your code is shared below. Notice the new lines that I have added.

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

You would notice that: 1. the user specified value is being read in oppVal variable. 2. the destination sheet name is always "Opportunity" 3. the code checks if the value in column A is equal to oppVal and then copies it over to destination sheet.

The code gets the job done, however, some enhancements you may do: 1. Clear the data in destination sheet before each run 2. use filters to select the rows instead of loop and then copy-paste the selected rows.

Answer 2

If you already have a worksheet "Opportunity", the code below will clear that worksheet, then use the value from W11 on the Diagram worksheet to filter Column A of the Data worksheet and copy the range in one go, instead of row by row:

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