Copy rows to new sheets if condition is met [Solved/Closed]
I.Gal6
Posts Wednesday May 17, 2017Registration date
May 23, 2017
Last seen
-
May 17, 2017 at 05:08 AM - Latest reply: vcoolio1195
Posts Thursday July 24, 2014Registration dateModeratorStatus
September 22, 2018
Last seen
- 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
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.
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)
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.
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.