Create sheets and copy whole row based on unique values on column k

[ORoxo]

Guys,

In a usual situation, I would try to do it myself, but I don't have much time right now and could really use a hand.

Basically, I would need a macro to check column k and create the sheet "Construction" and copy all the rows which have Construction on column k to that sheet. Then it would go to Public Administration and do the same and so on and so forth.

Thanks for any help you are able to provide!

 

[vcoolio]

Hello Oroxo,

Try the following code placed in a standard module and assigned to a button:-

Sub CreateNewShtsTransferData()

    Dim sht As Worksheet
    Dim lr As Long, i As Long
    Dim ID As Object
    Dim key As Variant

Set sht = Sheet1
Set ID = CreateObject("Scripting.Dictionary")
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
lr = sht.Range("A" & Rows.Count).End(xlUp).Row
     
For i = 2 To lr
        If Not ID.Exists(sht.Range("K" & i).Value) Then
            ID.Add sht.Range("K" & i).Value, 1
       End If
Next i

For Each key In ID.keys
        If Not Evaluate("ISREF('" & key & "'!A1)") Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
        End If
    
sht.Range("K1:K" & lr).AutoFilter 1, key
    sht.[A1].CurrentRegion.Copy
       Sheets(key).Range("A" & Rows.Count).End(3).PasteSpecial xlValues
          Sheets(key).Columns.AutoFit
             sht.[K1].AutoFilter
Next key

sht.Select
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "All done!", vbExclamation

End Sub

Sheet1 is the assumed "Master" sheet from where all the data is sourced.


I hope that this helps.

Cheerio,
vcoolio.

 

[My Aswer Is This]

Try this:

Sub Test()
'Modified 4-20-18 7:40 AM EDT
Application.ScreenUpdating = False
Dim Master As String
Master = ActiveSheet.Name
Dim i As Long
Dim b As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp"
Sheets(Master).Activate
Dim Lastrow As Long
Dim Lastrowb As Long
Lastrow = Cells(Rows.Count, "K").End(xlUp).Row
Sheets(Master).Range("K1:K" & Lastrow).Copy Destination:=Sheets("Temp").Range("A1")
Lastrowb = Sheets("Temp").Cells(Rows.Count, "K").End(xlUp).Row
Sheets("Temp").Range("A1:A" & Lastrowb).RemoveDuplicates Columns:=1, Header:=xlNo
Lastrowb = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To Lastrowb
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sheets("Temp").Cells(i, 1).Value
    Next
Sheets(Master).Activate
    For b = 1 To Lastrow
    Rows(b).Copy Destination:=Sheets(Cells(b, "K").Value).Rows(Sheets(Cells(b, "K").Value).Cells(Rows.Count, "K").End(xlUp).Row + 1)
    Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Sheets(Master).Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[ORoxo]

Hello Oroxo,

Try the following code placed in a standard module and assigned to a button:-

Sub CreateNewShtsTransferData()

    Dim sht As Worksheet
    Dim lr As Long, i As Long
    Dim ID As Object
    Dim key As Variant

Set sht = Sheet1
Set ID = CreateObject("Scripting.Dictionary")
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
lr = sht.Range("A" & Rows.Count).End(xlUp).Row
     
For i = 2 To lr
        If Not ID.Exists(sht.Range("K" & i).Value) Then
            ID.Add sht.Range("K" & i).Value, 1
       End If
Next i

For Each key In ID.keys
        If Not Evaluate("ISREF('" & key & "'!A1)") Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
        End If
    
sht.Range("K1:K" & lr).AutoFilter 1, key
    sht.[A1].CurrentRegion.Copy
       Sheets(key).Range("A" & Rows.Count).End(3).PasteSpecial xlValues
          Sheets(key).Columns.AutoFit
             sht.[K1].AutoFilter
Next key

sht.Select
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "All done!", vbExclamation

End Sub

Sheet1 is the assumed "Master" sheet from where all the data is sourced.


I hope that this helps.

Cheerio,
vcoolio.

Thank you so much, vcoolio! This is almost perfect!

For some reason, it works for every industry except Construction

 

[ORoxo]

Try this:

Sub Test()
'Modified 4-20-18 7:40 AM EDT
Application.ScreenUpdating = False
Dim Master As String
Master = ActiveSheet.Name
Dim i As Long
Dim b As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp"
Sheets(Master).Activate
Dim Lastrow As Long
Dim Lastrowb As Long
Lastrow = Cells(Rows.Count, "K").End(xlUp).Row
Sheets(Master).Range("K1:K" & Lastrow).Copy Destination:=Sheets("Temp").Range("A1")
Lastrowb = Sheets("Temp").Cells(Rows.Count, "K").End(xlUp).Row
Sheets("Temp").Range("A1:A" & Lastrowb).RemoveDuplicates Columns:=1, Header:=xlNo
Lastrowb = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To Lastrowb
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sheets("Temp").Cells(i, 1).Value
    Next
Sheets(Master).Activate
    For b = 1 To Lastrow
    Rows(b).Copy Destination:=Sheets(Cells(b, "K").Value).Rows(Sheets(Cells(b, "K").Value).Cells(Rows.Count, "K").End(xlUp).Row + 1)
    Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Sheets(Master).Range("A1").Select
Application.ScreenUpdating = True
End Sub

Hey,

Your answer generated an error in the following line:

Error being "Name is already taken. Try a different one.". It generates a sheet called "Temp" and a "Sheetx" being x the number of the new sheet and that error appears.

I appreciate your help though! If you want to have a look and get back to me I would be more than glad to try the updated version

 

[ORoxo]

Thank you so much, vcoolio! This is almost perfect!

For some reason, it works for every industry except Construction

I had the industries being retrieved with a formula. Pasted as values and it worked

 

[My Aswer Is This]

My script assumed none of the sheet names in column K had already been created. And temporarily I created a sheet named Temp that would have then been deleted at the end of the script.

 

[vcoolio]

Hi Oroxo,
Glad that it's all working as needed.
Glad to have been able to help.

Cheerio,
vcoolio