Sorting export Data

Hi All

I have an export from a system that I need to sort so that it is easier to work with.

I would like to do this through VBA. I have attached a copy of a sample file. Sheet 1 is how the report will export. Sheet 2 is the ideal output of the report.

Also I have a couple of considerations to take in to account and this is where I am getting stuck:

1 - The team size of the team will change depending on which team I have exported the data for. This would mean that the ranges would need to be dynamic. Employee will always appear to the left of a date and above the peoples names.

2 - The Labour Number is not an individual reference instead this links people back to a Department & Area

3 - any field which contains data like "M 8:00" would need to be changed to something such as "MAT/PAT"

That should pretty much cover it all but if you do have any questions please feel free to drop me a line I will be more than happy to help

Thank you in advance for any support that you may be able to give

D

Originally Posted by Bernie Deitrick

Your example workbook only has one sheet, so there is no 'ideal' sorting to view

Hi thanks for the quick response I uploaded the attachment before I had saved the changes to the work book .

Here is I have now added the correct work book to this post.

Hope that this helps more than the last one did

this collates the data, then you can remove the unwanted EMPLOYEE recs, zero work,etc
rename M8:00
and parse the WorkTime into StartTime and EndTime

run: aParseTime

Sub aParseTime()
Dim vRowdate, vWord, vDat
Dim iRows As Long, iCols As Long, c As Long, iOff As Long
Dim shtSrc As Worksheet, shtTarg As Worksheet
Dim sColLtr As String

Set shtSrc = ActiveSheet
Range("B1").Select
FarDown
iRows = ActiveCell.Row

'INSERT 1 COL. A
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B2").Select
iCols = ActiveSheet.UsedRange.Columns.Count
Range("A1").Select
SetHdrs
  
  'new results sheet
Sheets.Add
Set shtTarg = ActiveSheet
SetHdrs
shtSrc.Activate

Range("C2").Select  'start at EMP NAME column
For c = 4 To iCols
    iOff = c - 3
    sColLtr = getColLtr(Cells(2, c))
    Range("C2").Select
    While ActiveCell.Value <> ""
       vWord = ActiveCell.Offset(0, iOff).Value
       vDat = HasDoW(vWord)
       If vDat <> "" Then vRowdate = vDat
       
       ActiveCell.Offset(0, -2).Value = vRowdate
       NextRow
    Wend

     Columns(sColLtr & ":" & sColLtr).Copy
     'Range(sColLtr & "2:" & sColLtr & iRows).Copy
    Range("B1").Select
    PasteIt
    
       'copy 3 columns
    Range("A2:C" & iRows).Copy
    shtTarg.Activate
    Range("A1").Select
    FindNextFreeRec
    PasteIt

    'clear the source fields
    shtSrc.Activate
    Columns("A:B").Select
    Selection.ClearContents
    Range("A1").Select
Next   'repeat

  'delete all EMPLOYEE recs
shtTarg.Activate
SortResults

Set shtSrc = Nothing
Set shtTarg = Nothing
End Sub


Private Sub NextRow()
ActiveCell.Offset(1, 0).Select   'next row
End Sub

Private Sub FarDown()
    Selection.End(xlDown).Select
End Sub



Private Function HasDoW(ByVal pvWord)
Dim vDow, vDat
vDow = Left(pvWord, 3)
vDat = Mid(pvWord, 4)

Select Case vDow
  Case "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"
     HasDoW = vDat
  Case Else
     HasDoW = ""
End Select
End Function


Private Sub SetHdrs()
Range("A1").Value = "WorkDate"
Range("B1").Value = "TimeWorked"
Range("C1").Value = "EMP"
End Sub


Private Sub FindNextFreeRec()
Range("A1").Select
Select Case True
   Case ActiveCell.Value = ""
   Case ActiveCell.Offset(1, 0).Value = ""
        NextRow
   Case Else
        FarDown
        NextRow
End Select
End Sub

Private Sub PasteIt()
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

Public Function getColLtr(prng As Range)
Dim i As Integer
Dim vAddr

vAddr = prng.Address
i = InStrRev(vAddr, "$")
getColLtr = Mid(vAddr, 2, i - 2)
End Function
   
Sub SortResults()

    Columns("A:C").Select
    ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("A2:A5000" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet5").Sort
        .SetRange Range("A1:C5000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$C$5000").AutoFilter Field:=3, Criteria1:="Employee"
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "workdate"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "time"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "emp"
    Range("A2").Select
End Sub

Hi jindon

Thanks for that, that is amazing.

Is there a way of setting the output to be on the same sheet every time at all?

Thank you again

D

Add sheet named "Sheet2" if not in the workbook.

Sub test()
    Dim a, i As Long, ii As Long, n As Long, AL As Object
    Dim myDate As Date
    Set AL = CreateObject("System.Collections.ArrayList")
    If Not [isref('sheet2'!a1)] Then Sheets.Add.Name = "Sheet2"
    With Sheets("sheet1")
        a = .Range("b2", .Cells.SpecialCells(11)).Value
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If a(i, 1) = "Employee" Then
                For ii = 2 To UBound(a, 2)
                    If a(i, ii) Like "*##/##/####" Then
                        a(i, ii) = Replace(a(i, ii), vbLf, "")
                        a(i, ii) = DateSerial(Val(Right$(a(i, ii), 4)), _
                        Val(Mid$(a(i, ii), 7, 2)), Val(Mid$(a(i, ii), 4, 2)))
                    End If
                Next
                n = i
            Else
                If a(i, 1) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                    End If
                    For ii = 2 To UBound(a, 2)
                        If IsDate(a(n, ii)) Then
                            If Not AL.Contains(a(n, ii)) Then AL.Add a(n, ii)
                            .Item(a(i, 1))(a(n, ii)) = a(i, ii)
                        End If
                    Next
                End If
            End If
        Next
        ReDim a(1 To .Count + 2, 1 To AL.Count + 1): AL.Sort
        For ii = 0 To AL.Count - 1
            a(1, ii + 2) = AL(ii): a(2, ii + 2) = AL(ii)
        Next
        For i = 0 To .Count - 1
            a(i + 3, 1) = .keys()(i)
            For ii = 2 To UBound(a, 2)
                a(i + 3, ii) = .items()(i)(a(1, ii))
            Next
        Next
    End With
    With Sheets("sheet2").[b1].Resize(UBound(a, 1), UBound(a, 2))
        .Parent.Cells.Clear
        .Value = a
        .Offset(, 1).Resize(2, .Columns.Count - 1).BorderAround Weight:=2
        .Rows(1).NumberFormat = "yyyy/m/d"
        .Rows(2).NumberFormat = "ddd""""dd/mm/yyyy"
        .Columns(1).Offset(2).Resize(.Rows.Count - 2).Borders.Weight = 2
        .WrapText = False
        .Columns.AutoFit
        .Rows.AutoFit
        .Offset(, 1).HorizontalAlignment = xlCenter
        With .Offset(2, 1).Resize(.Rows.Count - 2, .Columns.Count - 1)
            .Borders(11).LineStyle = xlDot
            .Borders(12).Weight = 2
            .BorderAround Weight:=2
        End With
        For ii = 2 To .Columns.Count Step 7
            .Columns(ii).Borders(7).LineStyle = 1
        Next
    End With
End Sub

Hi Again.

That is great and is working Fantastically. I have just noticed that some people have 2 lines of data. This is due to the way the information is exported by the systems (which can not be changed). is there a way of amending the VBA so that it does one of the 2 options below:

1. Only pulls out the pay codes for example "Hol 8:00, .Ho 4:00, Dec 8:00" and so on

2. Populate 2 worksheets with the lines of data. in worksheet one you would have the full day scheduled events in the second sheet you would have the partial/additional scheduled events.

I know that the above is a little confusing so if you have any questions or require a sample of data please let me know

Thank you again for all of the support with this it really is appreciated!

Thanks

D

Change

                    For ii = 2 To UBound(a, 2)
                        If IsDate(a(n, ii)) Then
                            If Not AL.Contains(a(n, ii)) Then AL.Add a(n, ii)
                            .Item(a(i, 1))(a(n, ii)) = a(i, ii)
                        End If
                    Next

to

                    For ii = 2 To UBound(a, 2)
                        If IsDate(a(n, ii)) Then
                            If Not AL.Contains(a(n, ii)) Then AL.Add a(n, ii)
                            .Item(a(i, 1))(a(n, ii)) = .Item(a(i, 1))(a(n, ii)) & _
                            IIf(.Item(a(i, 1))(a(n, ii)) <> "", ", ", "") & a(i, ii)
                        End If
                    Next