Copy rows to new sheets if condition is met

Solved/Closed
I.Gal
Posts
6
Registration date
Wednesday May 17, 2017
Status
Member
Last seen
May 23, 2017
- Updated on May 17, 2017 at 07:06 AM
vcoolio
Posts
1355
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
August 10, 2022
- May 24, 2017 at 12:58 AM
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

4 replies

vcoolio
Posts
1355
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
August 10, 2022
250
May 17, 2017 at 06:47 AM
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.
0
I.Gal
Posts
6
Registration date
Wednesday May 17, 2017
Status
Member
Last seen
May 23, 2017

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.
0