Copy to new sheet

[shadow12345]

I have this sheet

FRONT END - STAGE 1.xls
	A	B	C	D	E	F
1	DEPT	EDPNO.	BANK	VALUE	CUR	AMOUNT
2	LAI		G	11-Jan-05	GBP	182.00
3
4	LAP		G	18-Jan-05	GBP	66,768.46
5
6	LAT		G	25-Jan-05	EUR	24,762.61
7
8	LBJ		G	24-Jan-05	USD	885,219.85
9	LBJ		G	26-Jan-05	USD	152,873.11
10	LBJ		G	27-Jan-05	USD	6,531,245.21
Sheet2

what i would like to do is every time there is a blank line take the data above and put it in its own sheet.

there are a great many possible names to go into coloumn A but if it could set the new sheet (that it creates to the dept name that would be great.


Any idea's ?

 

[vconfused]

You can run the following code. It will work with your data. If you need it to bring the header information as well, let us know. Otherwise for each set of data it creates a new worksheet with the name of whatever is in column A. Now if you have multiple sets of data with the same value in A, you will get an error (as it is now) because you can't have two sheets with the same name:

Sub macro1()

Dim srcSheet As Worksheet
Dim lngRow As Long, lngLastRow As Long, lngLastinSet As Long

    Application.ScreenUpdating = False
    
    lngLastRow = Range("A65536").End(xlUp).Row 'get the last row with data in column A
    lngRow = 2 'starting with the data in row 2

    Set srcSheet = ActiveSheet
    
    Do While lngRow <= lngLastRow
        lngLastinSet = lngRow
        Do While Range("A" & lngLastinSet + 1) <> ""
            lngLastinSet = lngLastinSet + 1
        Loop
        Range("A" & lngRow & ":F" & lngLastinSet).Copy
        Worksheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = srcSheet.Range("A" & lngRow)
        ActiveSheet.Paste
        srcSheet.Select
        lngRow = lngLastinSet + 2
    Loop
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

 

[jindon]

Hi

try the code

it will check if there is a named sheet already or not.
if not, add new sheet, else add data to the exsisting sheet.

Sub distribute_data()
    Dim wsData As Worksheet, ws As Worksheet, LastR As Long
    Dim dic As Object, x, y, r As Range, flg As Balloon, i As Long
    Set wsData = Sheets("sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
With wsData
    For Each r In .Range("a2", .Range("a65536").End(xlUp))
        If r <> "" And Not dic.exists(r.Value) Then
            dic.Add r.Value, r.Row
        End If
    Next
End With
    x = dic.keys
    y = dic.items
    
    For i = LBound(x) To UBound(x)
        flag = False
            For Each ws In Sheets
                If ws.Name <> "Sheet1" And ws.Name = x(i) Then
                    flag = True
                    Exit For
                End If
            Next
            If flag = False Then
                Worksheets.Add before:=wsData
                ActiveSheet.Name = x(i)
                wsData.Rows(1).Copy Destination:=Sheets(x(i)).Rows(1)
                
                If i < UBound(x) Then
                    wsData.Rows(y(i) & ":" & y(i + 1) - 2).Copy Destination:=Sheets(x(i)).Rows(2)
                Else
                    LastR = wsData.Range("a65536").End(xlUp).Row
                    wsData.Rows(y(i) & ":" & LastR).Copy Destination:=Sheets(x(i)).Rows(2)
                End If
            Else
                lastR2 = Sheets(x(i)).Range("a65536").End(xlUp).Row
                If i < UBound(x) Then
                    wsData.Rows(y(i) & ":" & y(i + 1) - 2).Copy Destination:=Sheets(x(i)).Rows(2)
                Else
                    LastR = wsData.Range("a65536").End(xlUp).Row
                    wsData.Rows(y(i) & ":" & LastR).Copy Destination:=Sheets(x(i)).Rows(2)
                End If
            End If
    Next
    wsData.Move before:=Sheets(1)
    Application.ScreenUpdating = True
    Set wsData = Nothing
    Set dic = Nothing
    Erase x
    Erase y
End Sub

hope this helps

jindon

 

[jindon]

Hi

dorrection:

on 3rd line from the top in the Dim statement

"flg as Balloon"

should be

"flag As Boolean"

rgds,

jindon

 

[shadow12345]

That works, thank you that just saved me a bout two hours work every month

 

[shadow12345]

Does the last code account for header information ? it spliting it all up but the first sheet always has two copies of the header rows ? and some of the other mix the department names together ?

 

[jindon]

Hi,
If you are talking about my code,

1) Sheet1 col.A should have sorted and one blank row in between the accounts.
2) if there is a sheet for the account already exists, will copy the row from where the code found its account name in col.A to the row one before next blank cell.
4) if there is no sheet exist for the account then, add new sheet for the account and copy the headings and paste onto 1 st row of new sheet and do the same thing as above.

therefore, it is impossible to have multiple headings on ay\ny sheets.

Make sure that you have one blank cell in between each accounts as your sample.

rgds,

jindon

 

[shadow12345]

That would be why then i took the blank lines away, i have put them back and it works fine thank very much.


The code is a bit beyond me but if i change the sheet name were all the data is held to "Raw Data" which bit do i need to change in the code is it this bit ?


Set wsData = Sheets("raw data")

 

[jindon]

Hi

Yes, that's it!

and the code below doesn't need to have a blank cell in between the accounts

Sub distribute_data()
    Dim wsData As Worksheet, ws As Worksheet, LastR As Long
    Dim dic As Object, x, y, r As Range, flag As Boolean, i As Long
    Set wsData = Sheets("sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
With wsData
    For Each r In .Range("a2", .Range("a65536").End(xlUp))
        If r <> "" And Not dic.exists(r.Value) Then
            dic.Add r.Value, r.Row
        End If
    Next
End With
    x = dic.keys
    y = dic.items
    
    For i = LBound(x) To UBound(x)
        flag = False
            For Each ws In Sheets
                If ws.Name <> "Sheet1" And ws.Name = x(i) Then
                    flag = True
                    Exit For
                End If
            Next
            If flag = False Then
                Worksheets.Add before:=wsData
                ActiveSheet.Name = x(i)
                wsData.Rows(1).Copy Destination:=Sheets(x(i)).Rows(1)
                
                If i < UBound(x) Then
                    Sheets(x(i)).Rows("2:65536").Clear
                    wsData.Rows(y(i) & ":" & y(i + 1) - 1).Copy Destination:=Sheets(x(i)).Rows(2)
                Else
                    LastR = wsData.Range("a65536").End(xlUp).Row
                    Sheets(x(i)).Rows("2:65536").Clear
                    wsData.Rows(y(i) & ":" & LastR).Copy Destination:=Sheets(x(i)).Rows(2)
                End If
            Else
                If i < UBound(x) Then
                    Sheets(x(i)).Rows("2:65536").Clear
                    wsData.Rows(y(i) & ":" & y(i + 1) - 1).Copy Destination:=Sheets(x(i)).Rows(2)
                Else
                    LastR = wsData.Range("a65536").End(xlUp).Row
                    Sheets(x(i)).Rows("2:65536").Clear
                    wsData.Rows(y(i) & ":" & LastR).Copy Destination:=Sheets(x(i)).Rows(2)
                End If
            End If
    Next
    wsData.Move before:=Sheets(1)
    Application.ScreenUpdating = True
    Set wsData = Nothing
    Set dic = Nothing
    Erase x
    Erase y
End Sub

this should be more flexible to the change of number of records.
rgds,
jindon