VBA Search and Copy Data to Another Sheet

[unknownymous]

Hi Guys,

I have these data below and I was thinking of VBA codes where it will create 3 sheets based on Subject.

The 3 Sheets name is based on Subject as well:
Sheet 1 = Math
Sheet 2 = Science
Sheet 3 = History

Each tab has the same header as the raw data. If the subject is math then it will copy the data to Math tab. same thing with Science and History.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Number[/TD]
[TD]Name[/TD]
[TD]Points[/TD]
[TD]Source 2[/TD]
[TD]Subject[/TD]
[/TR]
[TR]
[TD]001[/TD]
[TD]Chen[/TD]
[TD]1000[/TD]
[TD]-[/TD]
[TD]Math[/TD]
[/TR]
[TR]
[TD]002[/TD]
[TD]Lia[/TD]
[TD]500[/TD]
[TD]-[/TD]
[TD]Math[/TD]
[/TR]
[TR]
[TD]003[/TD]
[TD]Ron[/TD]
[TD]400[/TD]
[TD]-[/TD]
[TD]Science[/TD]
[/TR]
[TR]
[TD]004[/TD]
[TD]May[/TD]
[TD]100[/TD]
[TD]-[/TD]
[TD]History[/TD]
[/TR]
</tbody>[/TABLE]



Any help will be much appreciated.

 

[Fluff]

Is the data you want to filter on academic subjects as shown, or is it something completely different?

 

[unknownymous]

Hi Fluff,

You are correct. It is based on the academic subject. After running the macro, an excel sheet will be generated with four sheet tabs: 1) All Data, 2) Math, 3) Science, 4) History.

Also, if there's "Algebra" in the Subject column, it will be added under Math category.



Thanks a lot for the help.

 

[lrobbo314]

Try this. It won't name the one sheet 'History', because it is a reserved name. So this code will name the sheet 'Hist'.

Sub CopySubjectsOver()
Application.ScreenUpdating = False
Dim Main As Worksheet:      Set Main = Sheets("All Data")
Dim AR() As Variant:        AR = Main.Range("A1:E" & Main.Range("A" & Rows.Count).End(xlUp).Row).Value
Dim wName As String
Dim ws As Worksheet

For i = LBound(AR) + 1 To UBound(AR)
    Select Case AR(i, 5)
        Case "Math", "Algebra"
            wName = "Math"
        Case "Science"
            wName = "Science"
        Case "History"
            wName = "Hist"
    End Select
    
    If Not WorksheetExists(wName) Then
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = wName
        ws.Range("A1:E1") = Application.Index(AR, 1, 0, 1)
    Else
        Set ws = Sheets(wName)
    End If
    
    ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(1, 5).Value = Application.Index(AR, i, 0, 1)
    
Next i
Main.Activate

Application.ScreenUpdating = True
End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

 

[vcoolio]

Hello Unknownymous,

Here's another option:-

Sub CreateNewShtsTransferData()

       Dim sht As Worksheet, lr As Long, x As Long
       Dim IdO As Object
       Dim key As Variant

       Set sht = Sheet1  '----> Sheet1 being your "Master" sheet?
       Set IdO = CreateObject("Scripting.Dictionary")
             
Application.ScreenUpdating = False
Application.DisplayAlerts = False
                 
lr = sht.Range("A" & Rows.Count).End(xlUp).Row
sht.Range("F2:F" & lr) = "=IF(OR(E2=""Math"",E2=""Algebra""),""Maths"",IF(E2=""History"",""Hist"",E2))"

For x = 2 To lr
       If Not IdO.Exists(sht.Range("F" & x).Value) Then
             IdO.Add sht.Range("F" & x).Value, 1
       End If
Next x

For Each key In IdO.keys
       If Not Evaluate("ISREF('" & key & "'!A1)") Then
       Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
End If
   
With sht.[A1].CurrentRegion
        .AutoFilter 6, key
        .Columns("A:E").Copy Sheets(key).[A1]
        sht.[A1].AutoFilter
        End With
Next key

sht.Select
sht.Columns(6).Clear
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

I hope that this helps.

Cheerio,
vcoolio.

 

[lrobbo314]

Nice VCOOLIO! Yours is much faster. The autofilter is clearly the better way to do this. I ran speed tests and yours was blazing fast compared to mine.

Just for grins I tried to see if it could go any faster. I shaved about a tenth of a second off running it on 12,000 rows, and it's essentially your code. Either way, here's the update.

Sub CopySubjectsOver()
Application.ScreenUpdating = False
Dim Main As Worksheet:      Set Main = Sheets("All Data")
Dim AR() As Variant:        AR = Main.Range("A1:E" & Main.Range("A" & Rows.Count).End(xlUp).Row).Value
Dim SD As Object:           Set SD = CreateObject("Scripting.Dictionary")

For i = LBound(AR) + 1 To UBound(AR)
    Select Case AR(i, 5)
        Case "Math", "Algebra"
            wName = "Math"
        Case "Science"
            wName = "Science"
        Case "History"
            wName = "Hist"
    End Select
    
    If Not SD.exists(wName) Then SD.Add wName, 1
    
Next i

For Each key In SD.keys
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = key
    With Main.[A1].CurrentRegion
        If key = "Hist" Then
            .AutoFilter 5, "History"
        Else
            .AutoFilter 5, key
        End If
        .Columns("A:E").Copy Sheets(key).[A1]
        Main.[A1].AutoFilter
    End With
Next key

Main.Activate

Application.ScreenUpdating = True
End Sub

 

[vcoolio]

Good evening IRobbo,

Thanks for that. It nice to see someone else take an interest and make comparisons for the sake of further efficiency. You've actually made my day (I know, I need to get a life!).

All the best IRobbo and keep those codes coming!

Cheerio,
vcoolio.

 

[unknownymous]

Thanks a lot Vcoolio and Irobbo!

 

[vcoolio]

You're welcome Unknownymous.
Glad we could help and thanks for the feed back.

Cheerio,
vcoolio.