Sub Jucyla()
Dim FileName As String
Dim FileNum As Long
Dim Sh As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Sheets("Jucyla").Select
Cells.Select
Selection.ClearContents
Sheets.Add.Name = "Jucyla_S"
FileName = "C:\Temp\Source.txt"
FileNum = FreeFile
Open FileName For Output As FileNum
Print #FileNum, GetSource("https://swgoh.gg/u/jucyla/collection/")
Close FileNum
Set Sh = Worksheets.Add
With Sh.QueryTables.Add(Connection:="TEXT;C:\TEMP\Source.txt", Destination:=Range("a1"))
.Name = "Source"
.AdjustColumnWidth = True
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileColumnDataTypes = Array(2)
.Refresh BackgroundQuery:=False
End With
Columns("A:A").Select
Selection.Copy
Sheets("Jucyla_S").Select
Columns("A:A").Select
ActiveSheet.Paste
Range("A1").Select
Dim DL&, LD&
Application.ScreenUpdating = False
With Worksheets("Jucyla_S")
.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
DL = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To DL
If InStr(1, .Cells(i, 1), "<img class=""char") > 0 Then
LD = Worksheets("Jucyla").Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(i, 1).Resize(11).Copy
Worksheets("Jucyla").Cells(LD, 1).PasteSpecial xlValues
End If
Application.CutCopyMode = False
Next
End With
Worksheets("Jucyla").Range("A:A").Columns.AutoFit
Dim EL&, ED&, j&, a$, b$, c$, d$, x&
Application.ScreenUpdating = False
j = 1
With Worksheets("Jucyla")
EL = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EL
If InStr(1, .Cells(i, 1), "<img class=""char-portrait-full") > 0 Then
On Error Resume Next
a = Split(.Cells(i, 1).Text, """")(UBound(Split(.Cells(i, 1).Text, """")) - 1)
c = Split(Split(.Cells(i + 9, 1).Text, ">")(1), "<")(0)
d = Split(Split(.Cells(i + 10, 1).Text, ">")(1), "<")(0)
For j = 1 To 7
If InStr(1, .Cells(i + 1 + j, 1), "inactive") = 0 Then
x = x + 1
End If
Next
b = x
.Cells(i, "B").Resize(, 4) = Array(a, b, c, d)
x = 0
End If
Next
.Columns("B:E").Columns.AutoFit
.Columns(1).Delete
.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Set trouve = Sheets("Jucyla_S").[A:A].Find(what:="Last updated:", LookIn:=xlValues, lookat:=xlPart)
If Not trouve Is Nothing Then
débutDate = Mid(trouve, InStr(1, trouve, "title=", vbTextCompare) + 7, 30)
Sheets("Jucyla").[F1] = Trim(Left(débutDate, InStr(1, débutDate, "UTC", vbTextCompare) - 1))
Else
MsgBox "Pas trouvé la mention ""Last updated"" en colonne A"
End If
Sheets("Jucyla_S").Select
ActiveWindow.SelectedSheets.Delete
Application.ScreenUpdating = True
Sheets("Macro").Select
On Error Resume Next
Application.DisplayAlerts = False
For i = 1 To 100
sheetname = Cells(i + 1, 1).Value
ActiveWorkbook.Sheets(sheetname).Delete
Next
Application.DisplayAlerts = True
End Sub