Extract Data and Add Sheet or Copy to Existing Sheet

[helpexcel]

So this this the code i'm using to extract the data based on column B and putting it into new sheets named after Column B. I'd like to add code that says if the sheet exists, then paste on that sheet in next available row instead of adding a new sheet.

Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim WS As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next

Set r = Sheet1.Range("B:B")

On Error GoTo 0

If r Is Nothing Then Exit Sub

iCol = r.Column
t = Now

With Sheet1
    Master = .Name
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(3, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(3, 1), .Cells(lastrow, LastCol)).Sort Key1:=.Cells(3, 8), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    .Range(.Cells(3, 1), .Cells(lastrow, LastCol)).Sort Key1:=.Cells(3, iCol), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 4
    For i = 4 To lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set WS = ActiveSheet
            On Error Resume Next
            WS.Name = .Cells(iStart, iCol).Value & "Fruit"
            On Error GoTo 0
             WS.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(3, 1), .Cells(3, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=WS.Range("A2")
            iStart = iEnd + 1
            Cells.Select
            Cells.EntireColumn.AutoFit
        End If
    Next i
End With

 

[NdNoviceHlp]

You can trial this new and revised code. HTH. Dave

Public Function WsExists(WsName As String) As Boolean
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Sheets
If Ws.Name = WsName Then
WsExists = True
Exit For
End If
Next Ws
End Function


'your code
For i = 4 To lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            If WsExists(CStr(.Cells(iStart, iCol).Value & "Fruit")) Then
            Set Ws = Sheets(CStr(.Cells(iStart, iCol).Value & "Fruit"))
            Else
            Sheets.Add after:=Sheets(Sheets.Count)
            Set Ws = ActiveSheet
            Ws.Name = .Cells(iStart, iCol).Value & "Fruit"
            End If
             Ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(3, 1), .Cells(3, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=Ws.Range("A2")
            iStart = iEnd + 1
            Cells.Select
            Cells.EntireColumn.AutoFit
        End If
    Next i
'your code

 

[NdNoviceHlp]

whoops...This is wrong...

If WsExists(CStr(.Cells(iStart, iCol).Value & "Fruit")) Then
            Set Ws = Sheets(CStr(.Cells(iStart, iCol).Value & "Fruit"))

Should be...

If WsExists(CStr(.Cells(iStart, iCol).Value) & "Fruit") Then
            Set Ws = Sheets(CStr(.Cells(iStart, iCol).Value) & "Fruit")

My apologies. Dave

 

[helpexcel]

thanks!! It works fine when creating and populating the new sheets. However, when the sheet already exists, I get a Run Time 1004 Error Method Range Of Object Worksheet Failed on this line.

Ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = ws1.Range(.Cells(3, 1), .Cells(3, LastCol)).Value

 

[NdNoviceHlp]

U don't have a worksheet "ws1" but it looks like the code should be....

Ws.Range(Ws.Cells(1, 1), Ws.Cells(1, LastCol)).Value = .Range(.Cells(3, 1), .Cells(3, LastCol)).Value

Dave

 

[helpexcel]

That's what I had, and it errored out. So I thought if I added the ws1, and set it as Sheet1, it would work.

Thinking I do need to change the Cells to .Cells...thanks!

 

[NdNoviceHlp]

Did the revised code work? Dave

 

[helpexcel]

It's not adding data to the existing sheets. It creates new sheets, naming them "Sheet3, Sheet4"

 

[NdNoviceHlp]

I don't have your data setup to trial your code so really can't determine what's wrong with the data transfer. This code works to either set your worksheet ("Ws") to either an existing sheet based on the value of Sheet1 "B4" or it creates a new sheet named "B4" if the worksheet does not exist. Not sure that I'm of any further help without more information re. your data setup. HTH. Dave

 Public Function WsExists(WsName As String) As Boolean
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Sheets
If Ws.Name = WsName Then
WsExists = True
Exit For
End If
Next Ws
End Function

Sub test()
Dim Ws As Worksheet
Dim sh As Worksheet
iCol = 2 'column
iStart = 4 'row
Set sh = ThisWorkbook.Sheets("Sheet1")
With sh
'if "B4" & "Fruit" sheet exists
If WsExists(CStr(.Cells(iStart, iCol).Value) & "Fruit") Then
Set Ws = Sheets(CStr(.Cells(iStart, iCol).Value) & "Fruit")
Else
'if "B4" & "Fruit" sheet does NOT exists then make sheet "B4" & Fruit"
With ThisWorkbook
Set Ws = .Sheets.Add(after:=.Worksheets(Sheets.Count))
Ws.Name = CStr(sh.Cells(iStart, iCol).Value) & "Fruit"
End With
End If
End With
End Sub

 

[helpexcel]

Thanks! I was actually running the wrong macro, it didn't add new sheets, but it didn't copy to existing sheets either. I added that code above and it works to create and copy to new sheets, but won't copy to existing sheets.