AW: Commandbutton Beschriftung
30.10.2021 09:46:00
Nepumuk
Hallo,
viel lässt sich da nicht rausholen:
Private Sub Commandbutton13_Click()
Const FILE_PATH As String = "E:\"
Dim strFilename As String
Dim lngRow As Long
Dim strFilePath As String
Dim objFileDialog As FileDialog
Dim objWorkbook As Workbook
Dim loLetzte As Long, varArray As Variant, i As Long
Application.ScreenUpdating = False
With Worksheets("FilmDB")
.Activate
'Löscht alles
.Range("A2:J5000").ClearContents
Set objWorkbook = Workbooks.Open(Filename:="C:\Users\hansm\OneDrive\!alle filme1.csv")
Call objWorkbook.Worksheets(1).Columns("A:J").Copy(Destination:=.Cells(1, 1))
'Schließt !!alle filme1.csv
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
'Jahr ausschneiden und weiter nach vorne verschieben
.Columns(8).Copy Destination:=.Columns(4)
.Columns(8).Delete Shift:=xlToLeft
'Schrift Ausrichtung von A-J
.Columns("A:B").HorizontalAlignment = xlLeft
.Columns("C:C").HorizontalAlignment = xlCenter
.Columns("D:E").HorizontalAlignment = xlLeft
.Columns("F:I").HorizontalAlignment = xlCenter
.Columns("J").HorizontalAlignment = xlCenter
.Range("A1:I1").HorizontalAlignment = xlCenter
'Spaltenbreite
.Columns("A:A").ColumnWidth = 53.71
.Columns("B:D").ColumnWidth = 64.43
.Columns("C:C").ColumnWidth = 12.89
.Columns("D:D").ColumnWidth = 69.7
.Columns("E:F").ColumnWidth = 42.88
.Columns("G:H").ColumnWidth = 18.17
.Columns("I:J").ColumnWidth = 10.07
'Hintergrund Schwarz Einfärben
Application.Goto Reference:="FilmDb"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Schrift vergrößern auf 14 und Farbe Gelb zuweisen
With Selection.Font
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.799981688894314
.ThemeFont = xlThemeFontMinor
.Bold = True
.Name = "Calibri"
.Size = 14
End With
'Zeile 1 Schrift und Hintergrundfarbe ändern
With .Range("A1:J1")
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Font
.Size = 16
.Bold = False
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
' Doppel Punkte Löschen
Application.Goto Reference:="FilmDb"
Selection.Replace What:=":", Replacement:="", LookAt:=xlPart
'Leeerzeichen nach letzten buchstaben löschen
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
varArray = .Range(.Cells(1, 1), .Cells(loLetzte, 1)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1)
varArray(i, 1) = Trim$(varArray(i, 1))
Next i
.Range(.Cells(1, 1), .Cells(loLetzte, 1)).Value = varArray
'Gibt Auskunft über die Anzahl der Filme
.Range("A1").FormulaLocal = "=""Original Titel "" & Anzahl2(A2:A5000)"
End With
Worksheets("FilmeAnsehen").Activate
Unload Me
'Liest aus Verzeichniss E:\ Alle Filme aus und gibt sie als Link aus
Call LinkE_Click
End Sub
Gruß
Nepumuk