How do i extract merged data and put them into different worksheets?

问题

How do i use excel vba to extract merged data selectively(not manually clicking and copying from the excel sheet and also not specifically listing the range of the data that i want to copy. What i want is in a way such that the programme extract the entire row that has the same type of name from column F to column H for example Martin_1,Martin_2 and Martin _3 respectively for different names(John, Charlie) and copy and paste them to a new worksheet.

Put the extracted data into 3 different sheets namely index 1, index 2 and index 3 as shown below

Here is my attempted code:

dim i as integer
dim lastmartinrow as integer
dim c as string
dim j as integer
dim lastjohnrow as integer
dim b as string
dim k as integer
dim lastcharlierow as integer
dim a as string

for i = 1 to lastmartinrow
Set c = .Find("Martin_1","Martin_2",Martin_3" LookIn:=xlValues)
If c Is Nothing Then
'find the last row has the same "Martin_1","Martin_2","Martin_3") 
'copy the entire rows from 1 to lastmartinrow and paste it to a new worksheet("Index1").name
for j = lastmartinrow + 1 to lastjohnrow
Set b = .Find("John_1","John_2","John_3" LookIn:=xlValues)
If b Is Nothing Then
'find the last row has the same "John_1","John_2","John_3") 
'copy the entire rows from lastmartinrow + 1 to lastjohnrow and paste it to a new worksheet("Index2").name
for k = lastjohnrow + 1 to lastcharlierow
Set a = .Find("Charlie_1","Charlie_2",Charlie_3" LookIn:=xlValues)
If a Is Nothing Then
'find the last row has the same Charlie_1","Charlie_2",Charlie_3") 
'copy the entire rows from lastjohnrow + 1 to lastcharlierow and paste it to a new worksheet("Index3").name

error for the updated code Because previously i didnt save the spreadsheet when it crashed so this is the new sheet1 i am using right now.. [![enter image description here][6]][6]

回答1:

I have created a generic code, It will copy all the matching values(John,Marin,Charlie etc) present in F to H columns and paste it in Index3 sheet. It will not copy values with single row means which are not matching with any other row(immediately after that).

Sub UpdateVal()
    Static count As Long
    Dim iRow As Long
    Dim aRow As Long
    Dim a As Long
    Dim b As Long
    Dim selectRange As Range
    j = 2
    iRow = 1
    LastLine = ActiveSheet.UsedRange.Rows.count
    While iRow < LastLine + 1
        a = iRow + 1
        b = iRow + 17 ' Max Group Size with Same name in F to H column
        count = 1
        If Cells(iRow, "F").Value = "Martin1" Then
            sheetname = "Index1"
        ElseIf Cells(iRow, "F").Value = "John1" Then
            sheetname = "Index2"
        Else
            sheetname = "Index3"
        End If
        For aRow = a To b
            If Cells(iRow, "F") = Cells(aRow, "F") And Cells(iRow, "G") = Cells(aRow, "G") And Cells(iRow, "H") = Cells(aRow, "H") Then
                count = count + 1
            Else
                Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
                selectRange.Copy
                indexrowcount = Sheets(sheetname).UsedRange.Rows.count
                Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
                iRow = iRow + count
                Exit For
           End If
        Next aRow
    Wend
End Sub

来源：https://stackoverflow.com/questions/60069416/how-do-i-extract-merged-data-and-put-them-into-different-worksheets