Copy rows to new sheets if condition is met Solved/Closed

Question

Hello , please help... I'm trying to copy rows from master table sheet to different sheets based on the value of the cell in the column: 

The column "AL" contains several values (validation list) for example dog, cat, giraffe... I'd like to automatically open new sheet for every value and copy the relevant rows to the new sheet. (the new sheets must have the name of the value). 

In addition when a new data is added, I need the new rows to be added to the correct sheet 

Sub Copy_Data() 
Dim r As Range, LastRow As Long, ws As Worksheet 
Dim v As Variant, s As String, LastRow1 As Long 
Dim src As Worksheet 
Set src = Sheets("Sheet1") 
LastRow = src.Cells(Cells.Rows.Count, "AL").End(xlUp).Row 
s = "dog,cat,fish,giraffe" 
v = Split(s, ",") 
For Each r In src.Range("AL1:AL" & LastRow) 
 If Not IsError(Application.Match(CStr(r.Value), v, 0)) Then 
 On Error Resume Next 
 Set ws = Sheets(CStr(r.Value)) 
 On Error GoTo 0 
 If ws Is Nothing Then 
 Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value) 
 LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "AL").End(xlUp).Row 
 src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1) 
 Set ws = Nothing 
 Else 
 LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "Al").End(xlUp).Row 
 src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1) 
 Set ws = Nothing 
 End If 
 End If 
Next r 
End Sub

Thank you for your help

vcoolio · Answer

Hello I.Gal,

I assume that you have a problem with the code that you posted so try the following code instead (untested):-

Option Explicit

Sub CreateSheetsTransferData()
        Dim ar As Variant
        Dim i As Integer
        Dim lr As Long
        Dim ws As Worksheet
        Dim sh As Worksheet

Application.ScreenUpdating = False

lr = Range("A" & Rows.Count).End(xlUp).Row
Set sh = Sheet1
ar = sh.Range("AL2", sh.Range("AL" & sh.Rows.Count).End(xlUp))

For i = LBound(ar) To UBound(ar)
        If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1)
        End If
        Set ws = Worksheets(CStr(ar(i, 1)))
        sh.Range("AL1:AL" & lr).AutoFilter 1, ar(i, 1)
        sh.Range("A1", sh.Range("AL" & sh.Rows.Count).End(xlUp)).Copy ws.[A1]
        ws.Columns.AutoFit
  Next i
sh.[AL1].AutoFilter

Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
MsgBox "All done!", vbExclamation, "STATUS"

End Sub

Place the code in a standard module and assign it to a button.
The code will create new sheets for each unique value in Column AL and then transfer the relevant rows of data to their individual sheets.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello I.Gal,

No worries. Glad that I was able to help.

In line 22 of the above code, just change AL to whatever column is your last column of data. That should do the trick for you.

Cheerio,
vcoolio.

vcoolio · Answer

Hello I.Gal,

I've just tested the code in a mock-up of what I believe your work book looks like and all works as it should.

Could you please upload a sample of your work book so that I can have a look at its set out etc.. You can upload a sample to a free file sharing site such as DropBox, ge.tt or Sendspace and then post the link to your file back here. Please use dummy data in the sample.

I should then be able to sort it out for you.

Cheerio,
vcoolio.

vcoolio · Answer

Hello I.Gal,

That's interesting to say the least!

However, if it all works now as it should, then that is all that matters.

Glad that I was able to help.

Cheerio,
vcoolio.

Copy rows to new sheets if condition is met

4 responses

Similar discussions

Subscribe To Our Newsletter!