Extraction of Data based on dynamic criteria

[thespardian]

I simply want a dynamic way to group the above data . if there is empty cell in the column J (Centre) then ignore the whole row otherwise extract the data groups as per below format.

Any help will be highly appreciated.
Here is the link for excel file
Question123.xlsx

 

[thespardian]

hth...

The vb code you provided is showing error at this line. Can you please check it again.

Thanks a lot for your detailed reply and the guidance.

 

[thespardian]

If you are looking for VBA method then try this
Note: The result sheet is named as Result in my code

Sub Extract()

Dim Centre$
Dim iRowData&, eRowData&, n&
Dim key As Variant
Dim cell As Range, rngData As Range
Dim dictCentre As Object
Dim wsData As Worksheet, wsResult As Worksheet
Dim wb As Workbook

Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Data")
Set wsResult = wb.Sheets("Result")
Set dictCentre = CreateObject("Scripting.Dictionary")

iRowData = 12
eRowData = wsData.Range("A" & iRowData).End(xlDown).Row

Set rngData = wsData.Range("A" & iRowData, "A" & eRowData)

' Store all Center names
For Each cell In rngData
    Centre = cell.Offset(0, 9)
    If Not dictCentre.Exists(Centre) Then
        dictCentre.Add Centre, Centre
    End If
Next

' Write Result for each Centre
n = 6
For Each key In dictCentre.Keys
    wsResult.Range("A" & n) = UCase(key)
    n = n + 1
    For Each cell In rngData
        If cell.Offset(0, 9) = key Then
            wsData.Range("A" & cell.Row, "I" & cell.Row).Copy
            wsResult.Range("A" & n).PasteSpecial (xlPasteValuesAndNumberFormats)
            n = n + 1
        End If
    Next
    n = n + 1
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

@ Zot -- These codes are working fine. But when i have an ampty cell in "Centre". It doesn't ignore it. I only need the data which a value in "Centre" Column

 

[Zot]

@ Zot -- These codes are working fine. But when i have an ampty cell in "Centre". It doesn't ignore it. I only need the data which a value in "Centre" Column

My fault I forgot about the condition where you did mention about this requirement. Then just add line to skip copy if the Center row is empty

Sub Extract()

Dim Centre$
Dim iRowData&, eRowData&, n&
Dim key As Variant
Dim cell As Range, rngData As Range
Dim dictCentre As Object
Dim wsData As Worksheet, wsResult As Worksheet
Dim wb As Workbook

Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Data")
Set wsResult = wb.Sheets("Result")
Set dictCentre = CreateObject("Scripting.Dictionary")

iRowData = 12
eRowData = wsData.Range("A" & iRowData).End(xlDown).Row

Set rngData = wsData.Range("A" & iRowData, "A" & eRowData)

' Store all Center names
For Each cell In rngData
    Centre = cell.Offset(0, 9)
    If Not dictCentre.Exists(Centre) Then
        dictCentre.Add Centre, Centre
    End If
Next

' Write Result for each Centre
n = 6
For Each key In dictCentre.Keys
    wsResult.Range("A" & n) = UCase(key)
    n = n + 1
    For Each cell In rngData
        If Not Len(Range("J" & cell.Row)) = 0 Then                                                ' Skip the line if Center is empty
            If cell.Offset(0, 9) = key Then
                wsData.Range("A" & cell.Row, "I" & cell.Row).Copy
                wsResult.Range("A" & n).PasteSpecial (xlPasteValuesAndNumberFormats)
                n = n + 1
            End If
        End If
    Next
    n = n + 1
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

 

[thespardian]

@ Zot -- These codes are working fine. But when i have an ampty cell in "Centre". It doesn't ignore it. I only need the data which a value in "Centre" Column

I have some empty cells in the start of Column "Centre" and the results are as under. The data from Sr. 1 to 17 is not required.

 

[thespardian]

My fault I forgot about the condition where you did mention about this requirement. Then just add line to skip copy if the Center row is empty

Sub Extract()

Dim Centre$
Dim iRowData&, eRowData&, n&
Dim key As Variant
Dim cell As Range, rngData As Range
Dim dictCentre As Object
Dim wsData As Worksheet, wsResult As Worksheet
Dim wb As Workbook

Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Data")
Set wsResult = wb.Sheets("Result")
Set dictCentre = CreateObject("Scripting.Dictionary")

iRowData = 12
eRowData = wsData.Range("A" & iRowData).End(xlDown).Row

Set rngData = wsData.Range("A" & iRowData, "A" & eRowData)

' Store all Center names
For Each cell In rngData
    Centre = cell.Offset(0, 9)
    If Not dictCentre.Exists(Centre) Then
        dictCentre.Add Centre, Centre
    End If
Next

' Write Result for each Centre
n = 6
For Each key In dictCentre.Keys
    wsResult.Range("A" & n) = UCase(key)
    n = n + 1
    For Each cell In rngData
        If Not Len(Range("J" & cell.Row)) = 0 Then                                                ' Skip the line if Center is empty
            If cell.Offset(0, 9) = key Then
                wsData.Range("A" & cell.Row, "I" & cell.Row).Copy
                wsResult.Range("A" & n).PasteSpecial (xlPasteValuesAndNumberFormats)
                n = n + 1
            End If
        End If
    Next
    n = n + 1
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Thanks a lot for your prompt reply. It working. You gave me the strength of knowledge for which i am really thankful. Thanks again for taking time. Stay blessed.

 

[Zot]

Thanks a lot for your prompt reply. It working. You gave me the strength of knowledge for which i am really thankful. Thanks again for taking time. Stay blessed.

Thanks for the update. Glad to have the code works.

 

[fadee2]

The vb code you provided is showing error at this line. Can you please check it again.

Thanks a lot for your detailed reply and the guidance.

oops... typo error.
hth... was not part of the original code, my bad... you can remove it.

 

[thespardian]

Thanks for the update. Glad to have the code works.

@Zot Sorry to bother you again. I am facing a strange problem. When i assign the macro to the button. The results are incorrect. But when i run the code (by clicking Developer > Visual Basic> Module1 and hit the play button or f5). The results are accurate. I am attaching the file. Can you please check it for me.
Zot.xlsm

 

[thespardian]

oops... typo error.
hth... was not part of the original code, my bad... you can remove it.

Still not working for me. I am attaching the file. Can you please guide me where am i wrong?
Fadee2.xlsm

 

[Zot]

@Zot Sorry to bother you again. I am facing a strange problem. When i assign the macro to the button. The results are incorrect. But when i run the code (by clicking Developer > Visual Basic> Module1 and hit the play button or f5). The results are accurate. I am attaching the file. Can you please check it for me.
Zot.xlsm

I clicked the button and I don't see anything wrong on the Result sheet. What was not correct? I probably missed something.