Mein VBA Versuch (funktioniert)
08.02.2023 08:56:25
Christian
So, mein Versuch, nicht wundern, ich habe noch einiges mehr in das Makro integriert als bislang hier angesprochen.
Hauptmakro:
Sub Makro1()
Application.ScreenUpdating = False
If Dir("C:\Users\Christian\Downloads\*.csv", vbNormal) > "" Then
Kill "C:\Users\Christian\Downloads\*.csv"
End If
ActiveWorkbook.FollowHyperlink "https://www.imdb.com/list/ls562083064/export?ref_=nmls_exp"
ActiveWorkbook.FollowHyperlink "https://www.imdb.com/list/ls562085984/export?ref_=ttls_exp"
ActiveWorkbook.FollowHyperlink "https://www.imdb.com/list/ls562434110/export?ref_=nmls_exp"
Application.Wait (Now + TimeValue("0:00:25"))
ActiveWorkbook.Connections("Abfrage - Filme1").Refresh
ActiveWorkbook.Connections("Abfrage - Leute1").Refresh
Application.Run Ergebnis
ActiveWorkbook.Connections("Abfrage - Alle_Film").Refresh
Application.Run Rang
ActiveWorkbook.Connections("Abfrage - U30_Datum").Refresh
ActiveWorkbook.Connections("Abfrage - U30").Refresh
Application.Run Rang2
With Worksheets("Filme")
.Columns("A:Q").EntireColumn.AutoFit
End With
With Worksheets("Leute")
.Columns("A:H").EntireColumn.AutoFit
End With
With Worksheets("30")
.Columns("A:H").EntireColumn.AutoFit
.Columns("J:R").EntireColumn.AutoFit
.Columns("T:AB").EntireColumn.AutoFit
End With
With Worksheets("Ergebnis")
.Columns("A:G").EntireColumn.AutoFit
End With
With Worksheets("NV")
.Columns("A:G").EntireColumn.AutoFit
.Columns("C:C").Font.Italic = True
.Columns("C:C").Font.Bold = False
'.Columns("C:C").Font.Name = "Calibri"
.Columns("C:C").Font.Size = 11
.Columns("C:C").HorizontalAlignment = xlCenter
End With
With Worksheets("Punkte")
.Columns("A:BK").EntireColumn.AutoFit
End With
With Worksheets("letzte")
.Columns("A:C").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
Sheets("Punkte").Select
End Sub
Das Makro Ergebnis:
Sub Ergebnis()
Dim loLetzte As Long
Application.ScreenUpdating = False
Sheets("Ergebnis").Select
With Worksheets("Ergebnis").ListObjects(1).DataBodyRange
With .Columns(2)
.NumberFormat = "General"
.FormulaLocal = "=XVERWEIS(A2;Filme!B:B;Filme!F:F;"""";0;1)"
.NumberFormat = "@"
.Formula = .Value2
End With
With .Columns(3)
.FormulaLocal = "=WENN(XVERWEIS(A2;Filme!B:B;Filme!N:N;"""";0;1)=0;"""";XVERWEIS(A2;Filme!B:B;Filme!N:N;"""";0;1))"
.Formula = .Value2
End With
With .Columns(5)
.FormulaLocal = "=XVERWEIS(D2;Leute!B:B;Leute!F:F;"""";0;1)"
.Formula = .Value2
End With
With .Columns(6)
.FormulaLocal = "=WENN(XVERWEIS(D2;Leute!B:B;Leute!H:H;"""";0;1)=0;"""";XVERWEIS(D2;Leute!B:B;Leute!H:H;"""";0;1))"
.Formula = .Value2
End With
With .Columns(7)
.FormulaLocal = "=XVERWEIS(A2;Filme!B:B;Filme!H:H;"""";0;1)"
.Formula = .Value2
End With
End With
With Worksheets("Ergebnis")
loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("C2:C" & loLetzte), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Range("F2:F" & loLetzte), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A2:G" & loLetzte)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Range("A2").Select
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Das Makro Rang:
Sub Rang()
Application.ScreenUpdating = False
Sheets("30").Select
With Worksheets("30").ListObjects(1).DataBodyRange
With .Columns(8)
.FormulaLocal = "=RANG(F2;F$2:F2;0)"
.Formula = .Value2
End With
.Range("A1").Select
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Das Makro Rang2:
Sub Rang2()
Application.ScreenUpdating = False
Sheets("30").Select
With Worksheets("30").ListObjects(2).DataBodyRange
With .Columns(9)
.FormulaLocal = "=ZÄHLENWENN(U:U;M2)"
.Formula = .Value2
End With
End With
With Worksheets("30").ListObjects(3).DataBodyRange
With .Columns(9)
.FormulaLocal = "=ZÄHLENWENN(M:M;U2)"
.Formula = .Value2
End With
.Range("A1").Select
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub