VBA beschleunigen
18.09.2021 17:33:12
oraculix
Ich kopiere per Hand aus einer HTML Datei eine menge Daten in meine Tabelle und das Macro übernimmt den Rest.
Ich habe mit dem Macro Recorder einen Code erstellt der mir über 3000Bilder löscht und die Tabelle Formatiert und unnötige Eintrage löscht.
Doch leider dauert es ca. 40sek.
Wäre dankbar wenn sich ein Profi das Macro ansieht und mir einen Tipp gibt wie ich es beschleunigen kann !
'FilmInfo Aktualisieren
Private Sub CommandButton1_Click()
Dim lngLetter As Long
Dim objCell As Range
Dim objShp As Shape
Application.ScreenUpdating = False
With Worksheets("FilmInfo")
For Each objShp In .Shapes
If objShp.Type = msoPicture Then objShp.Delete
Next
'Alles was keine Jahreszahlen hat löschen
For lngLetter = 65 To 90
Set objCell = .Columns(2).Find(What:=Chr$(lngLetter), _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then objCell.EntireRow.Delete
Next
Do
Set objCell = .Columns(2).Find(What:="Home", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
objCell.EntireRow.Delete
Else
Exit Do
End If
Loop
Do
Set objCell = .Columns(2).Find(What:="Alle Filme", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
objCell.EntireRow.Delete
Else
Exit Do
End If
Loop
Do
Set objCell = .Columns(2).Find(What:="Andere", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
objCell.EntireRow.Delete
Else
Exit Do
End If
Loop
Do
Set objCell = .Columns(2).Find(What:="0..9", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
objCell.EntireRow.Delete
Else
Exit Do
End If
Loop
End With
' Formatiern und Doppelpunkte löschen
Range("B2:B30000").Select
ActiveWindow.ScrollRow = 4573
ActiveWindow.ScrollRow = 4519
ActiveWindow.ScrollRow = 3659
ActiveWindow.ScrollRow = 2368
ActiveWindow.ScrollRow = 1265
ActiveWindow.ScrollRow = 486
ActiveWindow.ScrollRow = 2
Selection.Font.Bold = True
Selection.Font.Size = 14
With Selection.Font
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlLeft
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Entfert Leerzeichen vor Hyperlink beginn
Dim objHyperlink As Hyperlink
For Each objHyperlink In Worksheets("FilmInfo").Columns(2).Hyperlinks
With objHyperlink
.TextToDisplay = LTrim$(.TextToDisplay)
End With
Next
Range("B1").Select
'Sortieren
Call CommandButton2_Click
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
Columns("B:B").Select
ActiveWorkbook.Worksheets("FilmInfo").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("FilmInfo").Sort.SortFields.Add2 Key:=Range( _
"B2:B55433"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("FilmInfo").Sort
.SetRange Range("B1:B55433")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B1").Select
End Sub
Gruß
Oraculix