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]

I'm guessing it is copying to existing sheets just over top of existing information. I really don't understand what you're trying to do with these lines of code which seem like they may be executed more than once within the loop...

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")

This line...

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

puts the values from sheet1 A3 to Lastcolumn3 (ie. row3) to the existing/new worksheet at A1 to Lastcolumn1 (ie. row1)
What happens if there are more than 1 similar non-consecutive "B" values? U are looping this for each row unless there is a match of 2 consecutive "B" rows from 4 to lastrow (should be lastrow -1 by the way) in sheet1....

For i = 4 To lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then

Seems like it may be repetitive if some "B" values repeat non consecutively. But won't hurt anything.
Now this line is more than likely the problem....

 .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=WS.Range("A2")

which says copy some range of rows from sheet1 column A to Last column to the existing/new "fruit" sheet anchored at "A2". OK, so paste this range below the previously transferred row (from the code above), but I can't really follow what rows from sheet1 that U want copied to the existing/new "fruit" sheet? There is no code reason for it to copy to new sheets but not to existing sheets. U will need some conditional code (ie. If new is sheet created paste at A2 Else paste at the existing "fruit" sheet "A" & lastrow +1). Just determine the existing sheet's "A" lastrow before pasting so U can paste to the "A" & lastrow +1. HTH. Dave

 

[helpexcel]

That last line was the issue. I forgot to update it to account for data that was already copied. Thanks for you patience and help.

My goal with the code is to take the data from Sheet1 and put it in separate sheets based on the value in column B. I'm always adding data to sheet 1, so I needed code to recognize when a sheet already existed and just add to it.

 

[NdNoviceHlp]

You didn't indicate what row(s) of data U want transferred? Anyways, this seems like it would work for U providing U are transferring the row(s) U want. Dave

Sub tester()
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
Dim Lastrow2 As Long
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
Set sh = ThisWorkbook.Sheets("Sheet1")
With sh
'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
If (.Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value) Or (i = lastrow) Then
iEnd = i
'existing sheet
With sh
If WsExists(CStr(.Cells(iStart, iCol).Value) & "Fruit") Then
Set Ws = Sheets(CStr(.Cells(iStart, iCol).Value) & "Fruit")
Lastrow2 = Ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
Else
'new sheet
With ThisWorkbook
Set Ws = .Sheets.Add(after:=.Worksheets(Sheets.Count))
Ws.Name = CStr(sh.Cells(iStart, iCol).Value) & "Fruit"
Lastrow2 = 2
End With
End If
End With

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("A" & Lastrow2)
            
iStart = iEnd + 1
Cells.Select
Cells.EntireColumn.AutoFit
End If
Next i
End With
End Sub

ps. I've changed the "B" condition to accommodate the last row value

 

[helpexcel]

Thanks!!!

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave