Previous Topic Next Topic

Copy rows to new sheets if condition is met

Solved/Closed
Report
Posts
6
Registration date
Wednesday May 17, 2017
Status
Member
Last seen
May 23, 2017
 -
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021
 -
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
Related:

4 replies

Answer 1 / 4
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021
 241
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.
Report
Posts
6
Registration date
Wednesday May 17, 2017
Status
Member
Last seen
May 23, 2017
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.
Answer 2 / 4
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021
 241
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.
Report
Posts
6
Registration date
Wednesday May 17, 2017
Status
Member
Last seen
May 23, 2017
Hello vcoolio,
thanks again for taking the time to help me.
I changed it , but now only the headline is copied ...
Answer 3 / 4
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021
 241
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.
Report
Posts
6
Registration date
Wednesday May 17, 2017
Status
Member
Last seen
May 23, 2017
Hello vcoolio,
I opened new file and started again with this code and it works!!
Thank you very much for you help.

Best regards
Answer 4 / 4
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021
 241
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.
Ask a question