Creating A Macro to export data to another workbook!

[yorkie287]

I have a list of approximately 200 entries made up of the customer details charges, weight of products etc,

e.g.

ticket no>customer name>>product weight> rebate >>>source

122 >>>>customer A >>>>>30000kg >>>>>>£500 >>>>customer a yard
123>>>> customer B >>>>>12000kg >>>>>>>£0 >>>>>>outside yard
124>>>> customer C >>>>>12560kg >>>>>>£250>>>>> customer c yard
125>>>> customer B >>>>>13444kg>>> >>>>£300>>>>> outside yard
126>>>> customer C >>>>>16252kg>>> >>>£100>>>>> customer c yard
127>>>> Customer A >>>>>15452kg >>>>>>£50 >>>>>>customer a yard

this is just an example of the list i have infront of me, i would like to create a macro that collects all customer A data together, all customer B data together, and all customer C data together and then exports them either to indiviual workbooks or just to new sheets within the same workbook,

thanks for taking time to look at this
all feedback/help is welcomed
oli

 

[yorkie287]

in reality the customer names are stored in column G in my excel workbook if that makes any difference to anyone

 

[VoG]

Try Excel Explosion http://www.datapigtechnologies.com/freeware.htm

 

[yorkie287]

i need to create a macro not for my own use that can be exported within our internal server to others who need to use it, for example we get a weekly data sheet like the one posted above which needs to be sorted an automating this by the use of a macro will greatly reduce the time it is currently taken, but thanks for your help vog

 

[Sektor]

Is "122 >>>>customer A >>>>>30000kg >>>>>>£500 >>>>customer a yard" in one cell?

 

[VoG]

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

 

[yorkie287]

@ sektor no they are the cells i was unsure of how to format it on here, the >>>> are the spaces between the columns

 

[yorkie287]

@ vog thank u very much for your useful add ins i do not however understand what the coding means in the other post you refered me to, will it be the same if my point of search will always be row G would you be able to advise me on how to apply this code to my sheet

thanks

 

[VoG]

Press ALT + F11 to open the Visual Basic Editor, select Module from the Insert menu and paste into the white space on the right

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
 
'   Root folder = Desktop
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the dialog
    x = SHBrowseForFolder(bInfo)
    
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Sub Lapta()
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 = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    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:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 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
            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
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xls"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
End If
End Sub

Press ALT + Q to close the code window, press ALT + F8, click on Lapta then click the Run button. Follow the prompts.

 

[yorkie287]

Vog , I have been working on doing this half past 8 this morning and you have given me what i was trying to do, thanks very much you hero !