VBA for each function

[moxy85]

I have a table of data, seomthing like the below

Ref   |   Description   |   Qty   |   Unit   |   Rate   |   Total  |   Supplier
      |                 |         |          |          |          |
A     |     Widget 1    |    10   |   Nr     |  £5.00   | £50.00   |  ABC
B     |     Widget 2    |    50   |   Nr     |  £2.00   | £100.00  |  DEF    
etc.
etc.

I already have vba code that copys data from the Description, Qty, Unit column based on a criteria of the rate column.

What I end up with is a list of all the descriptions, qty & units on a single page.

What I now waht to do is have the VBA code create seperate worksheets based on the supplier column (1 for each supplier) and have the relevant information copied onto each of the worksheets.

I'm thinking I need to use for "For Each" statements but this is beyond my current capilities.

Please help

 

[VoG]

I think that Excel Explosion will do what you want http://www.datapigtechnologies.com/freeware.htm

 

[moxy85]

Now having a look, thanks

I hope its customizable

 

[moxy85]

Doesn't seem to work :S

 

[VoG]

Take a look here (scroll down a bit) http://www.mrexcel.com/forum/showthread.php?t=396069

Note that my code will sort your sheet first, so try it with a copy.

 

[moxy85]

That is what I want, but I need to adjust it to suit.

Can you help explain what each part of the code is doing so that I can try and make it fit my scenario?

Thanks for all your help :D

 

[moxy85]

code used is

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
 
With ActiveSheet
    lastrow = Range("A22").Row '.Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = Range("G22").Column ' .Cells(1, Columns.Count).End(xlToLeft).Column
    iStart = 2
    For i = 5 To lastrow
        If .Range("C" & i).Value <> .Range("C" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("C" & iStart).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[moxy85]

My Interpretation is:

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
 
With ActiveSheet
lastrow = Range("A22").Row '.Cells(Rows.Count, "A").End(xlUp).Row DEFINE LAST ROW LOCATION
LastCol = Range("G22").Column ' .Cells(1, Columns.Count).End(xlToLeft).Column DEFINE LAST COLUMN IN TABLE
 
iStart = 2 '????
For i = 5 To lastrow
If .Range("C" & i).Value <> .Range("C" & i + 1).Value Then ' FOR EACH DIFFERENT VALUE WITHIN COLUMN C 
iEnd = i  '????
Sheets.Add after:=Sheets(Sheets.Count) ' ADD SHEETS
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("C" & iStart).Value ' SET ADDED WORKSHEETS NAME AS PER VALUES FROM COLUM C 
 
On Error GoTo 0
 
'RANGE TO COPY
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[moxy85]

I'm trying to learn

 

[VoG]

This should do what you want.

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Range("G2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Range("G" & i).Value <> .Range("G" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("G" & iStart).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub