Report

Copy rows to new sheets if condition is met [Solved]

Ask a question I.Gal 6Posts Wednesday May 17, 2017Registration date May 23, 2017 Last seen - Last answered on May 24, 2017 at 12:58 AM by vcoolio
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
Helpful
+0
plus moins
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.
I.Gal 6Posts Wednesday May 17, 2017Registration date May 23, 2017 Last seen - May 18, 2017 at 01:26 AM
Hello vcoolio,
Thank you for you quick response and help, it works great, I just have one question-
what should I change in order to enable all columns to be copied ? (only columns A:AL are cpoied but there are more columns in the table)

Once again, thank you.
Reply
Leave a comment
Helpful
+0
plus moins
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.
I.Gal 6Posts Wednesday May 17, 2017Registration date May 23, 2017 Last seen - May 18, 2017 at 07:57 AM
Hello vcoolio,
thanks again for taking the time to help me.
I changed it , but now only the headline is copied ...
Reply
Leave a comment
Helpful
+0
plus moins
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.
I.Gal 6Posts Wednesday May 17, 2017Registration date May 23, 2017 Last seen - May 23, 2017 at 10:45 AM
Hello vcoolio,
I opened new file and started again with this code and it works!!
Thank you very much for you help.

Best regards
Reply
Leave a comment
Helpful
+0
plus moins
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.
Leave a comment

Member requests are more likely to be responded to.

Members can monitor the statuses of their requests from their account pages.

A CCM membership gives you access to additional options.

Not a member yet?

Sign up now. It takes less than a minute and is completely free!