[VBA] Format Yahoo Fantasy Players List

Since Yahoo doesn't provide the data in Excel or Txt format, I need to strip tags and remove blanks.

PlayerList(MLB)_v0.1_2023.xls

0.15MB

PlayerList(MLB)_v0.2_2023.xls

0.17MB

 

This is only the draft version and the VBA code will be updated.

 

Option Explicit

' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 0.1       2023-Feb-03             delRow(), findValue()
' 0.2       2023-Feb-03             getTeamName()
' **************************************************************************************

Sub delRow()
    'MsgBox ActiveCell.Range
    Dim lRowCnt, lCntAA, lCntAB As Long
    Dim rngAll As Range

    Application.ScreenUpdating = False
    Call stripTag 'remove tags
    
    lCntAA = Application.CountA(Range("A:A")) 'count of non blank cells under A
    lCntAB = Application.CountA(Range("B:B")) 'count of non blank cells under B
    
    If (lCntAA < lCntAB) Then '14 < 31
        'MsgBox "lCntAA < lCntAB"
        MsgBox "Columns are not destroyed."
        Columns("A").Delete
    Else '145 > 0
        'MsgBox "lCntAA >= lCntAB"
        MsgBox "Columns are split into rows."
    End If
    
    Cells(1, "A").Select
    Set rngAll = Range([A1], Cells(Rows.Count, "A").End(xlUp))
    lRowCnt = rngAll.Rows.Count
    Call findValue(lRowCnt) 'Delete the rows if the values are not needed
 
    'Cells(1, "B").Select
    'Set rngAll = Range([B1], Cells(Rows.Count, "B").End(xlUp))
    'lRowCnt = rngAll.Rows.Count
    'Call findValue(lRowCnt) 'Delete the rows if the values are not needed
    
    'Columns("A").SpecialCells(4).EntireRow.Delete 'delete empty cell rows
    'MsgBox Application.CountA(Range("A:A"))
    Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes 'delete ""
 
    Range("A1").Select
    ActiveWindow.ScrollRow = 1
    Application.ScreenUpdating = True
End Sub

Sub stripTag()
    'Cells.Select
    'Dim rngSelected As Range
    'Set rngSelected = New Cells.Select
    'Call stripHtml(rngSelected) 'remove html
    Cells.Hyperlinks.Delete     'remove hyperlink
    ActiveSheet.Pictures.Delete 'remove pictures
    
    'MsgBox Application.CountA(Range("A:A")) & ", " & Application.CountA(Range("B:B"))
    'MsgBox Len(Range("A9:A9"))
End Sub

Private Sub findValue(ByVal lRowCnt As Long)
    Dim i, r As Integer
    Dim sSheetName As String
    Dim sActiveCellValue As String
    
    sSheetName = getTeamName
    
    For i = 1 To lRowCnt
        sActiveCellValue = ActiveCell.Value
        If IsNumeric(sActiveCellValue) Then
            Selection.EntireRow.Delete
            lRowCnt = lRowCnt - 1
            r = r + 1
        ElseIf sActiveCellValue Like "*player Notes" Or sActiveCellValue Like "Player Note" Or sActiveCellValue = "DTD" Or sActiveCellValue = sSheetName Then
            Selection.EntireRow.Delete
            lRowCnt = lRowCnt - 1
            r = r + 1
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Next i
    MsgBox r & " rows deleted"

End Sub

Private Function getTeamName() As String
    On Error GoTo ec1
    Dim sSheetName As String
    Dim vSheetName As Variant
    
    sSheetName = ActiveSheet.Name
    vSheetName = Split(sSheetName, "(")
    'MsgBox vSheetName(0)
    
    getTeamName = vSheetName(0)
ec1:

End Function