Help with vb Bot

[Paulo]

I have a spreadsheet that has 2 colums and 5 rows

lets say it looks like this...

banana;10
apple;15
grapes;12
grapes;2
banana;7
I woul like to make a macro that
creates a single tab for each different fruit
so I would start with the original sheet 1 and after runing the macro I
would end up with 4 , the original, plus 1 banana tab, 1 grape tab and 1
apple tap
the second part would copy and past the rows that has the fruit in side the
specific tab.

i thanks in advance for the help

 

[Bernie Deitrick]

Paulo,

If you have a table with headers in the first row, try the macro below.

HTH,
Bernie
MS Excel MVP

Sub ExportSheetsFromDatabase()
'Based on the value in the first column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range

Set myArea = ActiveCell.CurrentRegion.Columns(1).Offset(1, 0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=1, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell
End Sub

 

[Paulo]

Thank you very much for your help Bernie,

I am begginer @ VBA so i am walking 1 step afthe the other...

I tried your code, but i am getting erro in this line.

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

 

[Rick Rothstein \(MVP - VB\)]

Assuming the sheet these items are on is named "Sheet1" and that the first
fruit is on Row 1, give this macro a try...

Sub ProcessFruit()
Dim x As Long
Dim LastRow As Long
Dim LastRowOnCopy As Long
Dim SheetName As String
Dim WS As Worksheet
Dim FoundIt As Boolean
With Worksheets("Sheet1")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = 1 To LastRow
For Each WS In Worksheets
If .Cells(x, "A").Value = WS.Name Then
FoundIt = True
Exit For
End If
Next
If Not FoundIt Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = .Cells(x, "A").Value
End If
With Worksheets(.Cells(x, "A").Value)
LastRowOnCopy = .Cells(Rows.Count, "A").End(xlUp).Row
If Len(.Cells(LastRowOnCopy, "A").Value) > 0 And _
LastRowOnCopy = 1 Then LastRowOnCopy = LastRowOnCopy + 1
Worksheets("Sheet1").Rows(x).EntireRow.Copy _
Destination:=.Cells(LastRowOnCopy, "A")
End With
Next
End With
End Sub


Rick

 

[Paulo]

Rick , thank you so much for helping out.
I am learning alot from your way of thinking on your code.

I can see some how (since i dont know much about coding) that your code is
able to tell if the fruit already has a tab or not. thats grate for me .

unfortunately i am getting debug @ this line.

With Worksheets(.Cells(x, "A").Value)

the first tab "banana"got created and it placed the first banana and the
number 10 on the tab

 

[Rick Rothstein \(MVP - VB\)]

I think the problem **may** be because your data doesn't start on Row 1.
Here is some revised code which allows you to set the data sheet's name and
the starting row for your data on that sheet via the Const (constant)
statements. Change them to match your conditions and see if that solves your
problem.

Sub ProcessFruit()
Dim x As Long
Dim LastRow As Long
Dim LastRowOnCopy As Long
Dim SheetName As String
Dim WS As Worksheet
Dim FoundIt As Boolean

Const DataSheetName As String = "Sheet1"
Const StartRowForData As Long = 2

With Worksheets(DataSheetName)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = StartRowForData To LastRow
For Each WS In Worksheets
If .Cells(x, "A").Value = WS.Name Then
FoundIt = True
Exit For
End If
Next
If Not FoundIt Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = .Cells(x, "A").Value
End If
With Worksheets(.Cells(x, "A").Value)
LastRowOnCopy = .Cells(Rows.Count, "A").End(xlUp).Row
If Len(.Cells(LastRowOnCopy, "A").Value) > 0 And _
LastRowOnCopy = 1 Then LastRowOnCopy = LastRowOnCopy + 1
Worksheets(DataSheetName).Rows(x).EntireRow.Copy _
Destination:=.Cells(LastRowOnCopy, "A")
End With
Next
End With
End Sub


Rick

 

[Bernie Deitrick]

Paulo,

You need to select a single cell within your contiguous database (no blank rows or columns) prior to
running the code.

HTH,
Bernie
MS Excel MVP

 

[Paulo]

TANKS AGAIN FOR HELPPING OUT.. RICK

my "Sheet1" is called Sheet1
I only have Sheet1 tab, i deleted the others.
and the matrix goes exacly like this.

x, A , B
1,grape, 7
2,grape, 5
3,apple, 6
4,apple, 4
5,melon, 5
6,pineapple, 7
7,grape, 15

whith this new code
the result was:
it added the tab grape, its matrix have only row 1: colum A: grape colum B: 5
it added tab apple, its matrix have 2 rows, row 1: apple 6 and row 2: apple 4

and I got debug on the same line.

With Worksheets(.Cells(x, "A").Value)

 

[Paulo]

thanks again Bernie.

for now I am runing on the simpliest DB i could make. it is just as I
described, I have no blank row, or headers or any thing. just those 7 rows
with couple fruits randomly distributed . and i repet some fruits. thats it.
A , B
1,grape 7
2,grape 5
3,apple 6
4,apple 4
5,melon 5
6,pineapple 7
7,grape 15

just like that

 

[Rick Rothstein \(MVP - VB\)]

I was able to duplicate your problem. It seems I forgot to reset the FoundIt
variable to False at the start of each loop. Because I did not do that, when
it got to "melon", which did not have its own worksheet, the FoundIt
variable was still True from the previous loop that added "apple" so when it
went to copy to the "melon" sheet it thought was there, the error was
generated because that sheet did not really exist. Try this code and see if
it works now...

Sub ProcessFruit()
Dim x As Long
Dim LastRow As Long
Dim LastRowOnCopy As Long
Dim SheetName As String
Dim WS As Worksheet
Dim FoundIt As Boolean

Const DataSheetName As String = "Sheet1"
Const StartRowForData As Long = 2

With Worksheets(DataSheetName)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = StartRowForData To LastRow
FoundIt = False
For Each WS In Worksheets
If .Cells(x, "A").Value = WS.Name Then
FoundIt = True
Exit For
End If
Next
If Not FoundIt Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = .Cells(x, "A").Value
End If
With Worksheets(.Cells(x, "A").Value)
LastRowOnCopy = .Cells(Rows.Count, "A").End(xlUp).Row
If Len(.Cells(LastRowOnCopy, "A").Value) > 0 And _
LastRowOnCopy = 1 Then LastRowOnCopy = LastRowOnCopy + 1
Worksheets(DataSheetName).Rows(x).EntireRow.Copy _
Destination:=.Cells(LastRowOnCopy, "A")
End With
Next
End With
End Sub


Rick

 

[Paulo]

Rick, You are the man...
It almos worked. i didnt understand very deeply what you just explaned. I am
gonna go trow a little more deeply I am ver new @ this.

this time it worked greate. but it diddnt add the last fruit: Grape to the
grape tab.

the way I think the code is working, it did not go trow the entire colum to
check if there was any other entry of the same fruit to copy and paste into
the tabs.

but i am very gratefull for your help I am learning alot from it.

Paulo

 

[Paulo]

actually

playing a littel with the DB

I cant tell what is really happening, because I have 10 fruit entrys now. 3
of them are grapes. number 1, 2 and 7 . the macro is able to add ut the tabs
correctly. but it just addes up the row 1 and row 7 skipping row 2.

I can't thank you enought Rick

 

[Paulo]

I figured It out,

the macro is coppying and pasting only the first and last fruit of each type
to the tab with that fruit name.

so that means thas each tab will only have max of 2 rows.
if the colum has and 2 type of fruits, grapes and apples 5 rows : apple,
apple , grape, grape, apple. the output will only be 2 tabs with 2 rows.
if you number the apples, as aple 1, 2 and 3. the apple tab would have
apple 1 and apple 3 , skipping aple 2

 

[Rick Rothstein \(MVP - VB\)]

Yes, I just spotted that myself. It seems I had some of my logic screwed up
regarding the selection of the last row on the copy sheets. Here is the
problem I was attempting to get around. when you do this...

LastRowOnCopy = .Cells(Rows.Count, "A").End(xlUp).Row

if there is nothing in the column, LastRowOnCopy is assigned a value of 1,
not 0. If there is something in Row 1, and nothing in any of the other rows,
LastRowOnCopy is again assigned a value of 1. The problem was in how I was
handling how to get to the first blank row after the last piece of data when
you get a 1 for both conditions above. I believe I now have the problem
solved. Give this code a try...

Sub ProcessFruit()
Dim x As Long
Dim LastRow As Long
Dim LastRowOnCopy As Long
Dim SheetName As String
Dim WS As Worksheet
Dim FoundIt As Boolean

Const DataSheetName As String = "Sheet1"
Const StartRowForData As Long = 1

With Worksheets(DataSheetName)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = StartRowForData To LastRow
FoundIt = False
For Each WS In Worksheets
If .Cells(x, "A").Value = WS.Name Then
FoundIt = True
Exit For
End If
Next
If Not FoundIt Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = .Cells(x, "A").Value
End If
With Worksheets(.Cells(x, "A").Value)
LastRowOnCopy = .Cells(Rows.Count, "A").End(xlUp).Row
If Len(.Cells(LastRowOnCopy, "A").Value) = 0 And _
LastRowOnCopy = 1 Then LastRowOnCopy = 0
Worksheets(DataSheetName).Rows(x).EntireRow.Copy _
Destination:=.Cells(LastRowOnCopy + 1, "A")
End With
Next
End With
End Sub


Rick

 

[Paulo]

Thank You very much for You help rick it worked smootly this time.
I am gonna try to aplly this to my other DB see what whappends.