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'SI개발 > VBA' 카테고리의 다른 글
| [VBA]디렉토리 안의 파일 목록 구하기2 (0) | 2022.12.11 |
|---|---|
| [VBA] 차트 범례 추가, 삭제 (0) | 2021.03.27 |
| [VBA]디렉토리 안의 파일 목록 구하기 (0) | 2017.10.28 |
| [VBA] 엑셀 디아블로2 my log(엑셀), jimmy's log(본문) (0) | 2016.03.27 |
| [VBA]Excel. DB칼럼명을 Camel, pascal로 변환 (0) | 2016.03.26 |
listFiles_v3.xls
