Extract Data and Add Sheet or Copy to Existing Sheet

helpexcel

Well-known Member
Joined
Oct 21, 2009
Messages
632
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.


VBA Code:
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,950
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...
Code:
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...
Code:
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....
Code:
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....
Code:
 .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
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

helpexcel

Well-known Member
Joined
Oct 21, 2009
Messages
632
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,950
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
Code:
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
 
Solution
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,772
Messages
5,766,387
Members
425,350
Latest member
procha

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top