Analyze data in specific way

**YasserKhalil** · 11-17-2015, 04:02 PM

Hello everyone
I need to analyze and split data in specific way
In fact it is hard to describe my issue ... so I have attached the expected output in "Final Sheet" starting in Column K till column Y
Hope it is clear (see the attachment)

**antoka05** · 11-18-2015, 06:52 AM

See attached file, this the code that I used:

Sub Maco1()
   Dim rs As Object, lastRow As Long
   Dim r As Long
   Dim sourceSh As Worksheet
   Dim finalSh As Worksheet
   Dim myEvent As String, myGender As String, myLcMeter As Single
   Dim myNatRec As String, myYear As Single, myName2 As String
   Dim myTeam2 As String, myHeat As Single, myStartTime As String
   Dim myType As String, myText As String, myText2 As String
   Dim myText3() As String, p1 As Integer
      
   Const adInteger = 3
   Const adSingle = 4
   Const adDate = 7
   Const adVarChar = 200
   Const adDouble = 5
   Const adBinary = 128
   
   On Error GoTo lbl_err
   
   Application.ScreenUpdating = False
   
   'create an ADODB.Recordset and call it rs
   Set rs = CreateObject("ADODB.Recordset")
      
   'create the various rows of the recordset
   With rs.Fields
      .Append "event", adVarChar, 12
      .Append "heat", adSingle
      .Append "lane", adSingle
      .Append "startTime", adVarChar, 12
      .Append "name", adVarChar, 35
      .Append "age", adSingle
      .Append "team", adVarChar, 8
      .Append "time2", adVarChar, 12
      .Append "gender", adVarChar, 7
      .Append "lcMeter", adSingle
      .Append "type", adVarChar, 24
      .Append "natRec", adVarChar, 10
      .Append "year", adSingle
      .Append "name2", adVarChar, 26
      .Append "Team2", adVarChar, 14
   End With
   rs.Open
   
   With ThisWorkbook
      Set sourceSh = .Sheets(1)
      Set finalSh = .Sheets(2)
   End With
   
   lastRow = sourceSh.Cells(Rows.Count, "a").End(xlUp).Row
   'carico dati
   For r = 1 To lastRow
      myText = sourceSh.Cells(r, "a")
      myText2 = Trim(myText)
      Do While InStr(myText2, "  ") > 0
         myText2 = Replace(myText2, "  ", " ")
      Loop
      myText3 = Split(myText2, " ")
      
      If myText Like "Event*" Then
         myEvent = Trim(Left(myText, 9))
         myGender = myText3(2)
         myLcMeter = CSng(myText3(6))
         myType = Trim(Mid(myText, 42, 20))
      ElseIf myText Like "*National:*" Then
         myNatRec = Trim(Mid(myText, 15, 8))
         myYear = CSng(Trim(Mid(myText, 25, 10)))
         p1 = InStrRev(myText, ",")
         myName2 = Trim(Mid(myText, 29, p1 - 29))
         myTeam2 = Trim(Mid(myText, p1 + 1))
      ElseIf myText Like "Heat*" Then
         myHeat = CSng(Trim(Mid(myText, 5, 3)))
         myStartTime = Trim(Mid(myText, 33, 10))
         
      ElseIf IsNumeric(Trim(Left(myText, 5))) Then
         rs.addnew
         rs("event") = myEvent
         rs("heat") = myHeat
         rs("lane") = CSng(Trim(Left(myText, 5)))
         rs("startTime") = myStartTime
         rs("name") = Trim(Mid(myText, 4, 32))
         rs("age") = CSng(Mid(myText, 36, 2))
         rs("team") = Trim(Mid(myText, 38, 6))
         rs("time2") = Trim(Mid(myText, 62, 10))
         rs("gender") = myGender
         rs("lcMeter") = myLcMeter
         rs("type") = myType
         rs("natRec") = myNatRec
         rs("year") = myYear
         rs("name2") = myName2
         rs("Team2") = myTeam2
         rs.Update
      End If
   Next r
  
   'if necessary to apply a filter
   'rs.Filter = "cognome like '*a*'"
   
   'sort [asc], desc
   rs.Sort = "event, heat,lane"
   
   'output data sorted and filtered
   With finalSh
      .Range("5:" & Rows.Count).Delete
      .Range("a5").CopyFromRecordset rs
      rs.Close
      Set rs = Nothing
   
      'formatting
      .Range("a:d").Font.Color = RGB(192, 0, 0)
      .Range("l:o").Font.Color = RGB(102, 112, 213)
      
      lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
      
      For r = lastRow To 7 Step -1
         If .Cells(r, 1) <> .Cells(r - 1, 1) Then
            .Rows(r & ":" & r + 6).Insert
            
            .Range("a3:o5").Copy .Cells(r + 5, 1)
         ElseIf .Cells(r, 2) <> .Cells(r - 1, 2) Then
            .Rows(r).Insert
         End If
      Next r
   End With

   Application.ScreenUpdating = True

lbl_exit:
   Exit Sub

lbl_err:
   'Stop
   'Resume Next
   
   MsgBox ("An error occurred in the code")
   Resume lbl_exit
End Sub

Regards,
Antonio

**YasserKhalil** · 11-18-2015, 01:05 PM

Thanks a lot Mr. Antonio for this awesome and fascinating code
Just a little remark ..
There is Event 33 repeated at all events at the beginning of each group
Take a look at the results

**antoka05** · 11-18-2015, 02:51 PM

Excuse me, in my code there was one error:

   .Range("a3:o5").Copy .Cells(r + 5, 1)

The right code is:

   .Range("a3:o3").Copy .Cells(r + 5, 1)

Regards,
Antonio

**YasserKhalil** · 11-18-2015, 03:18 PM

Thank you very much for this distinguished solution
It's perfect
Regards

**xladept** · 11-18-2015, 06:26 PM

Hi Yasser,

Here's mine:

Sub YasserSports(): Dim Hd As String, HL As Range, c As Long, r As Long, ws As Worksheet, wf As Worksheet
                    Dim E, N, H, Z, u As Long, v As Long, w As Long, x As Long, S As String: r = 3
Set ws = Sheets("Source Sheet"): Set wf = Sheets("Final Sheet"): ws.UsedRange.Offset(2).Copy wf.Range("A1")
Hd = "Event|Heat|Lane|Start Time|Name|Age|Team|Time|Gender|LC Meter|Type|National Record|Year|Name|Team"
        Columns("K:N").Font.ColorIndex = 3: Columns("V:Y").Font.ColorIndex = 31
Set HL = Cells(8, "K").Resize(1, 15): HL.Interior.ColorIndex = 43: HL.Value = Split(Hd, "|")
    HL.Borders.Weight = xlThin: HL.BorderAround Weight:=xlMedium: HL.Font.Bold = True
GetEv:
     Do: r = r + 1: Loop Until InStr(1, Range("A" & r), "Event")
     E = Split(WorksheetFunction.Trim(Range("A" & r))): v = UBound(E)
GetNat:
    Do: r = r + 1: Loop Until InStr(1, Range("A" & r), "National")
    N = Split(WorksheetFunction.Trim(Range("A" & r))): x = UBound(N)
    HL.Copy Cells(r + 2, "K")
GetHt:
        Do: r = r + 1: Loop Until InStr(1, Range("A" & r), "Heat")
        H = Split(WorksheetFunction.Trim(Range("A" & r))): w = UBound(H)
            Do: r = r + 1
                If InStr(1, Range("A" & r + 1), "Event") Then GoTo GetEv

                If r > Range("A" & Rows.count).End(xlUp).Row Then GoTo ExitSub
                Z = Split(WorksheetFunction.Trim(Range("A" & r))): u = UBound(Z)
                        
LoadLine: Range("K" & r) = E(0) & " " & E(1): Range("L" & r) = H(1): Range("M" & r) = Z(0)
          Range("N" & r) = H(w - 1) & " " & H(w):           Range("Y" & r) = N(x)
          For c = 1 To u - 3: S = S & " " & Z(c): Next c: Range("O" & r) = Trim(S): S = ""
          Range("P" & r) = E(3): Range("Q" & r) = Z(u - 1): Range("R" & r) = Z(u)
          S = E(2): Range("S" & r) = Left(S, Len(S) - 1): S = "": Range("T" & r) = E(v - 3)
          Range("U" & r) = E(v): Range("V" & r) = N(1): Range("W" & r) = N(2)
          For c = 3 To x - 1: S = S & " " & N(c): Next c: Range("X" & r) = Trim(S): S = ""
          If InStr(1, Range("A" & r + 1), "Heat") Then GoTo GetHt
          
            Loop Until r > Range("A" & Rows.count).End(xlUp).Row
ExitSub:                wf.Columns("K:Y").AutoFit
End Sub

**YasserKhalil** · 11-18-2015, 06:40 PM

Thank you very much Mr. aka Orrin (Is that your real name?)
you provided me a great solution too ..
Thanks a lot for this great and wonderful help
Regards

**xladept** · 11-18-2015, 07:22 PM

Hi Yasser,

You're welcome and thanks for the rep - here's a correction for the ", 6 Oct:

Sub YasserSports(): Dim Hd As String, HL As Range, c As Long, r As Long, ws As Worksheet, wf As Worksheet
                    Dim E, N, H, Z, u As Long, v As Long, w As Long, x As Long, S As String: r = 3
Set ws = Sheets("Source Sheet"): Set wf = Sheets("Final Sheet"): ws.UsedRange.Offset(2).Copy wf.Range("A1")
Hd = "Event|Heat|Lane|Start Time|Name|Age|Team|Time|Gender|LC Meter|Type|National Record|Year|Name|Team"
        Columns("K:N").Font.ColorIndex = 3: Columns("V:Y").Font.ColorIndex = 31
Set HL = Cells(8, "K").Resize(1, 15): HL.Interior.ColorIndex = 43: HL.Value = Split(Hd, "|")
    HL.Borders.Weight = xlThin: HL.BorderAround Weight:=xlMedium: HL.Font.Bold = True
GetEv:
     Do: r = r + 1: Loop Until InStr(1, Range("A" & r), "Event")
     E = Split(WorksheetFunction.Trim(Range("A" & r))): v = UBound(E)
GetNat:
    Do: r = r + 1: Loop Until InStr(1, Range("A" & r), "National")
    S = WorksheetFunction.Trim(Range("A" & r)): S = Replace(S, ",", "")
    N = Split(S): x = UBound(N): S = N(x - 1) & " " & N(x)
                    If IsDate(S) Then
    N(x) = S: N(x - 1) = " ": S = "": End If
                HL.Copy Cells(r + 2, "K")
GetHt:
        Do: r = r + 1: Loop Until InStr(1, Range("A" & r), "Heat")
        H = Split(WorksheetFunction.Trim(Range("A" & r))): w = UBound(H)
            Do: r = r + 1
                If InStr(1, Range("A" & r + 1), "Event") Then GoTo GetEv

                If r > Range("A" & Rows.count).End(xlUp).Row Then GoTo ExitSub
                Z = Split(WorksheetFunction.Trim(Range("A" & r))): u = UBound(Z)
                        
LoadLine: Range("K" & r) = E(0) & " " & E(1): Range("L" & r) = H(1): Range("M" & r) = Z(0)
          Range("N" & r) = H(w - 1) & " " & H(w):           Range("Y" & r) = N(x)
          For c = 1 To u - 3: S = S & " " & Z(c): Next c: Range("O" & r) = Trim(S): S = ""
          Range("P" & r) = E(3): Range("Q" & r) = Z(u - 1): Range("R" & r) = Z(u)
          S = E(2): Range("S" & r) = Left(S, Len(S) - 1): S = "": Range("T" & r) = E(v - 3)
          Range("U" & r) = E(v): Range("V" & r) = N(1): Range("W" & r) = N(2)
          For c = 3 To x - 1: S = S & " " & N(c): Next c: Range("X" & r) = Trim(S): S = ""
          If InStr(1, Range("A" & r + 1), "Heat") Then GoTo GetHt
          
            Loop Until r > Range("A" & Rows.count).End(xlUp).Row
ExitSub:                wf.Columns("K:Y").AutoFit
End Sub

* Yes, Orrin is my real name (it means "Fair One" in the Welsh from which it was derived) - Does Yasser mean something??

**YasserKhalil** · 11-19-2015, 06:15 AM

Thanks a lot Mr. Orrin for correction
As for my name it means in Arabic (my language) the easy man ... What about aka (is this a name? or what?)

**xladept** · 11-19-2015, 03:30 PM

Hi Yasser,

AKA is a mnemonic for "Also Known As" it is used to describe an entities alias

The easy man? - You're projects are normally fairly complex

Analyze data in specific way

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Re: Analyze data in specific way

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Analyze number to specific results

[SOLVED] Macro to analyze the data

[SOLVED] Macro to analyze the Raw Data

How to analyze comment data

Formula to analyze data?

Using LOOPS with IF to analyze specific cell ranges

Analyze Data

Bookmarks

Bookmarks

Posting Permissions