Copy and paste part of data to new workbook and save in specific directory

[rachelka]

Hi

I have problem with macro, because I don't know how to make it.

I have some sheet with data . In column B I have only names with yellow interior.
After each name I have a few rows with data concerning this person (data from column A till J).
There is no blank rows because before this macro I deleted them.

And what I want to do is to split all data from this one sheet to new workbooks. Each of this workbooks should have name of this person from B column and data after but without data for another person.

Each of this workbook I want to save in the same directory but with different name.

I was thinking about do loop, do while etc., but I don't know how to make it.


Below I made some code but I don't know what to do next.

This macro select for me the first selection to copy to new workbook.
But I have more this.



Sub CopyPastetonewWorkbook ()

Dim a As Range
Dim b As Range

Workbooks("x").Activate
Columns("B:B").Select
Application.FindFormat.Interior.ColorIndex = 6
Selection.Find(What:="*", After:=ActiveCell, LookIn:=xlValues, Lookat:= _
xlPart,SearchOrder:=xlByColumns,SearchDirection:=xlNext,MatchCase:= _False, SearchFormat:=True).Activate

Set a = ActiveCell

Selection.FindNext(After:=ActiveCell).Activate

Set b = ActiveCell


a.Offset(0, -1).Resize((b.Row - a.Row), 10).Copy

b=a

End Sub


I was thinking about something like that.

Selection.FindNext(After:=ActiveCell).Activate

Set b = ActiveCell
a.Offset(0, -1).Resize((b.Row - a.Row), 10).Copy
b=a
Selection.FindNext(After:=ActiveCell).Activate
Set b = ActiveCell
a.Offset(0, -1).Resize((b.Row - a.Row), 10).Copy
b=a
etc.


Any suggestions will be welcomed

[fb7894]

Here is how to make a loop to cycle through cells in a column. This should get you started.

[VBA]Dim rCell As Range
Sub Loop_Example()
For Each rCell In Range("A1:A10")
If rCell.Interior.Color = vbYellow Then
MsgBox "this cell is yellow"
Else
MsgBox "this cell is not yellow"
End If
Next rCell
End Sub[/VBA]

[rachelka]

I attached file as en example.

I was thinking too about some named ranges.
But I don't have much experience with VBA yet.

1.Copy from yellow field to yellow field -1.
2. Create new worksheet
3. Paste cells
4. Save new worksheet in directory
2. Copy data from yellow field-1 to next yellow field .
and from the 2 point next.


[VBA]
Sub Utw?rzDoWysyłki()
Dim nazwa As String
Dim raport As Workbook

Set raport = createNewSheet("mobile")
raport.SaveAs Filename:=SciezkaDoAplikacji


End Sub

Function SciezkaDoAplikacji() As String
Dim sciezka As String
Dim mobile As Object

Set mobile = Workbooks("*")
sciezka = StrReverse(mobile.FullName)
sciezka = StrReverse(Right(sciezka, Len(sciezka) - InStr(sciezka, "\") + 1))

sciezka = sciezka + "to send mobile\" + "nazwa"
SciezkaDoAplikacji = sciezka

End Function

Function createNewSheet(nazwa As String) As Workbook
Dim Skoroszyt As Workbook
Set Skoroszyt = Application.Workbooks.Add()
Dim arkusz As Worksheet
For Each arkusz In Skoroszyt.Worksheets
If arkusz.Name = "Arkusz1" Then
arkusz.Name = nazwa
Else
Application.DisplayAlerts = False
arkusz.Delete
Application.DisplayAlerts = True
End If
Next
Set createNewSheet = Skoroszyt
End Function[/VBA]


This macro I found and it works very good.
So step by step Im closer to do what I want ( I hope).